├── .gitignore ├── .travis.yml ├── LICENSE ├── META6.json ├── README.FIRST ├── README.md ├── examples └── parse-fasta │ ├── README.md │ ├── fasta-from-p5.pl6 │ ├── fasta.pl6 │ └── grammar.pl6 ├── lib └── Bio │ ├── Annotation │ ├── Comment.pm6 │ ├── DBLink.pm6 │ ├── Reference.pm6 │ └── SimpleValue.pm6 │ ├── Grammar │ ├── Actions │ │ ├── Default.pm6 │ │ ├── Fasta.pm6 │ │ └── SeqDumper.pm6 │ ├── FTLocation.pm6 │ ├── Fasta.pm6 │ ├── GFF.pm6 │ └── Genbank.pm6 │ ├── Location │ └── Simple.pm6 │ ├── PrimarySeq.pm6 │ ├── Role │ ├── Aliased.pm6 │ ├── Annotatable.pm6 │ ├── Annotation.pm6 │ ├── Describable.pm6 │ ├── IO.pm6 │ ├── Identifiable.pm6 │ ├── Location.pm6 │ ├── Pluggable.pm6 │ ├── PrimarySeq.pm6 │ ├── Range.pm6 │ ├── RecordFormat.pm6 │ ├── SeqStream.pm6 │ └── Temp.pm6 │ ├── Root │ └── Root.pm6 │ ├── SeqIO.pm6 │ ├── SeqIO │ └── fasta.pm6 │ ├── Tools │ ├── CodonTable.pm6 │ ├── FTLocationParser.pm6 │ └── IUPAC.pm6 │ └── Type │ ├── Location.pm6 │ └── Sequence.pm6 ├── nyi ├── Bio │ ├── Factory │ │ └── FTLocationFactory.pm6 │ ├── LiveSeq │ │ └── Mutation.pm6 │ ├── Role │ │ ├── AnnotationCollection.pm6 │ │ ├── FastaIO.pm6 │ │ ├── Feature.pm6 │ │ ├── FeatureCollection.pm6 │ │ ├── IO.pm6 │ │ ├── Location.pm6 │ │ ├── Location │ │ │ ├── Fuzzy.pm6 │ │ │ ├── Simple.pm6 │ │ │ └── Split.pm6 │ │ └── RichSeq.pm6 │ ├── SeqFeature │ │ └── Lite.pm6 │ └── SeqIO.pm6 └── t │ ├── Factory │ └── FTLocationFactory.t │ ├── LiveSeq │ └── Mutation.t │ ├── Location.t │ ├── Location │ └── Simple.t │ ├── SeqFeature │ └── Lite.t │ └── SeqIO │ ├── fasta.t │ └── genbank.t └── t ├── 00-meta.t ├── Annotation ├── Comment.t ├── DBLink.t ├── Reference.t └── SimpleValue.t ├── Grammar ├── FTLocation.t └── Fasta.t ├── Location └── Simple.t ├── PrimarySeq.t ├── Range.t ├── Role ├── Aliased.t ├── Describable.t ├── IO.t ├── Identifiable.t ├── Pluggable.t └── Temp.t ├── Root.t ├── SeqIO.t ├── SeqIO └── fasta.t ├── Tools ├── CodonTable.t ├── FTLocationParser.t └── IUPAC.t ├── Types.t ├── data ├── canonical.gff3 ├── location_data.txt ├── multi_1.fa ├── roa1.genbank └── test.fasta └── lib └── MyTest └── PluginDir ├── Plugin1.pm6 └── Plugin2.pm6 /.gitignore: -------------------------------------------------------------------------------- 1 | *.DS_Store 2 | *~ 3 | .tmp 4 | *# 5 | .#* 6 | *(Autosaved)blib* 7 | *.tar.gz 8 | cover_db 9 | blib* 10 | *.bak 11 | MYMETA.yml 12 | *.moarvm 13 | *.pir 14 | *.precomp 15 | *.rev-deps 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | 3 | perl6: 4 | - latest 5 | 6 | os: 7 | - linux 8 | - osx 9 | 10 | sudo: false 11 | 12 | branches: 13 | except: 14 | - gh-pages 15 | 16 | install: 17 | - rakudobrew build-zef 18 | - zef --debug --depsonly install . 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2000-2006, The Perl Foundation. 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "tags" : [ "Bio", "Biology", "Science", "Bioinformatics", "Grammar" ], 3 | "perl" : "6.c", 4 | "name" : "BioPerl6", 5 | "license" : "Artistic-2.0", 6 | "version" : "0.0.1", 7 | "description" : "Collection of Bioinformatics classes, roles, and modules", 8 | "authors" : "git:cjfields", 9 | "depends" : [ "File::Temp" ], 10 | "provides" : { 11 | "Bio::Annotation::SimpleValue" : "lib/Bio/Annotation/SimpleValue.pm6", 12 | "Bio::Annotation::DBLink" : "lib/Bio/Annotation/DBLink.pm6", 13 | "Bio::Annotation::Reference" : "lib/Bio/Annotation/Reference.pm6", 14 | "Bio::Annotation::Comment" : "lib/Bio/Annotation/Comment.pm6", 15 | "Bio::Grammar::Actions::Default" : "lib/Bio/Grammar/Actions/Default.pm6", 16 | "Bio::Grammar::Actions::Fasta" : "lib/Bio/Grammar/Actions/Fasta.pm6", 17 | "Bio::Grammar::Actions::SeqDumper" : "lib/Bio/Grammar/Actions/SeqDumper.pm6", 18 | "Bio::Grammar::Fasta" : "lib/Bio/Grammar/Fasta.pm6", 19 | "Bio::Grammar::FTLocation" : "lib/Bio/Grammar/FTLocation.pm6", 20 | "Bio::Grammar::Genbank" : "lib/Bio/Grammar/Genbank.pm6", 21 | "Bio::Grammar::GFF" : "lib/Bio/Grammar/GFF.pm6", 22 | "Bio::Location::Simple" : "lib/Bio/Location/Simple.pm6", 23 | "Bio::PrimarySeq" : "lib/Bio/PrimarySeq.pm6", 24 | "Bio::Role::Aliased" : "lib/Bio/Role/Aliased.pm6", 25 | "Bio::Role::Annotatable" : "lib/Bio/Role/Annotatable.pm6", 26 | "Bio::Role::Annotation" : "lib/Bio/Role/Annotation.pm6", 27 | "Bio::Role::Describable" : "lib/Bio/Role/Describable.pm6", 28 | "Bio::Role::Identifiable" : "lib/Bio/Role/Identifiable.pm6", 29 | "Bio::Role::IO" : "lib/Bio/Role/IO.pm6", 30 | "Bio::Role::Location" : "lib/Bio/Role/Location.pm6", 31 | "Bio::Role::Pluggable" : "lib/Bio/Role/Pluggable.pm6", 32 | "Bio::Role::PrimarySeq" : "lib/Bio/Role/PrimarySeq.pm6", 33 | "Bio::Role::Range" : "lib/Bio/Role/Range.pm6", 34 | "Bio::Role::RecordFormat" : "lib/Bio/Role/RecordFormat.pm6", 35 | "Bio::Role::SeqStream" : "lib/Bio/Role/SeqStream.pm6", 36 | "Bio::Role::Temp" : "lib/Bio/Role/Temp.pm6", 37 | "Bio::Root::Root" : "lib/Bio/Root/Root.pm6", 38 | "Bio::SeqIO::fasta" : "lib/Bio/SeqIO/fasta.pm6", 39 | "Bio::SeqIO" : "lib/Bio/SeqIO.pm6", 40 | "Bio::Tools::CodonTable" : "lib/Bio/Tools/CodonTable.pm6", 41 | "Bio::Tools::FTLocationParser" : "lib/Bio/Tools/FTLocationParser.pm6", 42 | "Bio::Tools::IUPAC" : "lib/Bio/Tools/IUPAC.pm6", 43 | "Bio::Type::Location" : "lib/Bio/Type/Location.pm6", 44 | "Bio::Type::Sequence" : "lib/Bio/Type/Sequence.pm6" 45 | }, 46 | "source-type" : "git", 47 | "source-url" : "git://github.com/cjfields/bioperl6.git" 48 | } 49 | -------------------------------------------------------------------------------- /README.FIRST: -------------------------------------------------------------------------------- 1 | =BioPerl 6 (bioperl-experimental)= 2 | 3 | The experimental classes in this directory are test implementations for Perl 6. 4 | Most of these are similar to perl5-based BioPerl with simple Perl 6 5 | translations. Hear thar be dragoons. 6 | 7 | =Notes on Perl 6= 8 | 9 | Perl 6 is a specification and thus can represent multiple implementations. We 10 | recommend strictly following the Perl6 spec, defined in a series of synopses: 11 | 12 | http://design.perl6.org/ 13 | 14 | Note that much of the specification is still in flux or is unfinished; much of 15 | this is due to changes from experimenting with several preliminary Perl 6 16 | implementations, such as Pugs or Rakudo (Perl 6 on Parrot), and parsing Perl 6 17 | using Larry Wall's STD.pm grammar. 18 | 19 | Once the Perl 6 specification is considered complete, BioPerl 6 would then be 20 | expected to run on any Perl 6 implementation passing the official Perl 6 test 21 | suite. Until then, we will recommend the latest Parrot build from subversion 22 | along with the latest Rakudo checkout (currently packaged with Parrot but soon 23 | to be located in a separate repository). 24 | 25 | =Chris's Notes= 26 | 27 | ==Interfaces vs Classes== 28 | 29 | In general, I am defining strict interfaces as roles and interface 30 | implementations as classes. This is due to several interfaces actually defining 31 | methods that are common to all implementations. 32 | 33 | Defining interfaces as roles has a specific advantage, as roles can be mixed-in 34 | per instance at runtime or class-wide at compile time: 35 | 36 | # compile-time 37 | class Bio::PrimarySeq is Bio::Root::Root does Bio::RangeI { 38 | 39 | } 40 | 41 | # runtime mixin 42 | my $seq = Bio.PrimarySeq.new(); 43 | my $seq does Bio::AnnotatableI; 44 | 45 | ==Class Methods== 46 | 47 | Multiple dispatch. Named/positional/required/optional/slurpy/invocant 48 | parameters. Type checking. Variable return contexts (scalar, list, hash, etc.). 49 | 50 | ==Named parameters== 51 | 52 | Named parameters/arguments are now part of the Perl6 specification and can be 53 | passed using comma notation or using Pairs: 54 | 55 | my $seqobj = Bio::PrimarySeq.new(seq => $rawseq, description => $desc, :alphabet); 56 | 57 | Note that this diverges from perl5-based BioPerl conventions, where named arguments are 58 | prefixed with a dash ('-') character. 59 | 60 | ==Getter/Setters== 61 | 62 | ==Class Methods== 63 | 64 | ==Tests== 65 | 66 | None yet (soon to be added) 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/cjfields/bioperl6.svg?branch=master)](https://travis-ci.org/cjfields/bioperl6) 2 | 3 | # BioPerl 6 4 | 5 | The experimental classes in this directory are test implementations for Perl 6. 6 | Most of these are similar to perl5-based BioPerl with simple Perl 6 7 | translations. We intend on porting functionality when needed, but also 8 | addressing many of the problems faced with the perl5 BioPerl version, namely 9 | class/interface structure, overly complex class hierarchy, etc. 10 | 11 | So, keep in mind that nothing is set in stone yet and things may change under 12 | your feet. **Hic sunt dracones**. 13 | 14 | Also, just a note: this repository may eventually be moved under the BioPerl 15 | umbrella. If so, I'll leave stub repo here pointing to the correct location. 16 | 17 | # Participation 18 | 19 | If you have an itch to scratch and want to try it out, fork the code and hack 20 | away. Even better, *I can add you as a developer!* Drop me a note, I'm more than 21 | happy to have help. The more the better! 22 | 23 | # Targeting 24 | 25 | Currently, I target [Rakudo Perl 6](https://github.com/rakudo/rakudo) 26 | (specifically using the MoarVM backend) off the `nom` branch. We may switch at 27 | some point to a targeted Rakudo Star version for more stability, but since the 28 | latest branch code has seen dramatic improvements (as of Aug. 2014) we aim to 29 | stay consistent with that. 30 | 31 | Note, as of Dec. 25, 2015, Rakudo is now targeting the newly-released Perl 6 32 | official specification (6.c), therefore syntax is expected to have stabilized 33 | and focus will be fixing bugs, improving performance, and working out corners of 34 | the specification that need further clarification. 35 | 36 | # Implemented 37 | 38 | * `Bio::PrimarySeq` - this includes required basic modules for transcription and 39 | translation. 40 | * `Bio::Range` - simple biological range operations (don't confuse this with the 41 | Perl 6 Range class) 42 | * `Bio::Root` - original base class for BioPerl, though this may be removed in 43 | favor of using Perl 6 standard exception handling (which is leagues better 44 | than p5) 45 | 46 | # Testing 47 | 48 | Basically, one can do this: 49 | 50 | ``` 51 | prove -e 'perl6' -r t 52 | ``` 53 | 54 | which will run all tests. **This will certainly fail at this stage!** Most 55 | current tests are ports from the original BioPerl distribution, and the current 56 | code is in various stages of updating. We anticipate this changing more over 57 | the next year. 58 | 59 | To run a single test: 60 | 61 | ``` 62 | prove -e 'perl6' t/Root.t 63 | ``` 64 | 65 | # Notes 66 | 67 | Perl 6 is a specification and thus can represent multiple implementations. More 68 | in the Perl 6 [synopses](http://design.perl6.org/). 69 | 70 | # Related 71 | 72 | * [Matt Oates](http://blog.mattoates.co.uk) has some nice Perl6 bioinformatics code implemented in the [BioInfo project](https://github.com/MattOates/BioInfo) that demonstrates some of the power of Perl6, including slangs and concurrency. 73 | -------------------------------------------------------------------------------- /examples/parse-fasta/README.md: -------------------------------------------------------------------------------- 1 | # Example FASTA parsing 2 | 3 | The three examples here parse a FASTA file in three ways: 4 | 5 | 1. `fasta.pl6` - using bioperl6's implementation of Bio::SeqIO 6 | 7 | 2. `grammar.pl6` - using bioperl6's low-level grammar 8 | 9 | 3. `fasta-from-p5.pl` - using p5 Bio::SeqIO within Perl 6 10 | -------------------------------------------------------------------------------- /examples/parse-fasta/fasta-from-p5.pl6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | # This is using p5 BioPerl Bio::SeqIO 4 | use Bio::SeqIO:from; 5 | 6 | my $file = @*ARGS.shift; 7 | 8 | # Note: left side needs quotes; keys are not automaically strings in p6 9 | my $in = Bio::SeqIO.new('-format' => 'fasta', '-file' => $file); 10 | 11 | my $ct = 0; 12 | 13 | while $in.next_seq -> $record { 14 | $ct++; 15 | } 16 | 17 | say "Count: $ct"; 18 | -------------------------------------------------------------------------------- /examples/parse-fasta/fasta.pl6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::SeqIO; 3 | 4 | my $file = @*ARGS.shift; 5 | my $in = Bio::SeqIO.new(:format, :file($file)); 6 | 7 | my $ct = 0; 8 | 9 | while $in.next-Seq -> $record { 10 | $ct++; 11 | } 12 | 13 | say "Count: $ct"; 14 | -------------------------------------------------------------------------------- /examples/parse-fasta/grammar.pl6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::Grammar::Fasta; 3 | 4 | my $file = @*ARGS.shift; 5 | my $data = Bio::Grammar::Fasta.parsefile($file); 6 | 7 | my $ct = 0; 8 | for $data -> $record { 9 | $ct++; 10 | } 11 | 12 | say $ct; 13 | -------------------------------------------------------------------------------- /lib/Bio/Annotation/Comment.pm6: -------------------------------------------------------------------------------- 1 | use v6.c; 2 | 3 | use Bio::Role::Annotation; 4 | 5 | class Bio::Annotation::Comment does Bio::Role::Annotation { 6 | 7 | # TODO: in common w/ Bio::Annotation::Comment, move to role? 8 | has Str $.text is rw = ''; 9 | 10 | # TODO type attribute found in multiple places, put into role? 11 | has Str $.type is rw; 12 | 13 | # TODO: This is supposed to return a structured format (YAML/JSON/XML), but 14 | # maybe we need a simple factory for this? Seems like all public atts are 15 | # valid for use here, maybe should be implemented by role 16 | 17 | method hash-tree(){ ... } 18 | 19 | method Str() { 20 | return "Comment: " ~ $.text; 21 | } 22 | 23 | } 24 | -------------------------------------------------------------------------------- /lib/Bio/Annotation/DBLink.pm6: -------------------------------------------------------------------------------- 1 | use v6.c; 2 | 3 | use Bio::Role::Annotation; 4 | use Bio::Role::Identifiable; 5 | 6 | class Bio::Annotation::DBLink does Bio::Role::Annotation 7 | does Bio::Role::Identifiable { 8 | 9 | has Str $.database is rw; 10 | 11 | # TODO: maybe move to Identifiable role? Having one optional ID seems 12 | # limiting, and this is probably better defined in that role 13 | has Str $.optional-id is rw; 14 | 15 | # TODO: in common w/ Bio::Annotation::Comment, move to role? 16 | has Str $.comment is rw; 17 | 18 | # TODO: seeing type popping up more 19 | has Str $.type is rw; 20 | has Str $.url is rw; 21 | 22 | # TODO: This is supposed to return a structured format (YAML/JSON/XML), but 23 | # maybe we need a simple factory for this? Seems like all public atts are 24 | # valid for use here, maybe should be implemented by role 25 | 26 | method hash-tree(){ ... } 27 | 28 | method Str() { 29 | return "Direct database link to " ~ $.primary-id 30 | ~ ($.version ?? "." ~ $.version !! "" ) 31 | ~ ($.optional-id ?? " (" ~ $.optional-id ~ ")" !! "" ) 32 | ~ " in database " ~ $.database; 33 | } 34 | 35 | } 36 | -------------------------------------------------------------------------------- /lib/Bio/Annotation/Reference.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Annotation::DBLink; 4 | use Bio::Role::Range; 5 | 6 | class Bio::Annotation::Reference is Bio::Annotation::DBLink does Bio::Role::Range { 7 | 8 | has Str $.value is rw; 9 | 10 | # TODO: should this be an array or a simple string (leaving as Str for now) 11 | has Str $.authors is rw; 12 | has Str $.consortium is rw; 13 | has Str $.location is rw; 14 | has Str $.title is rw; 15 | 16 | # TODO: some of these could have stricter types 17 | has Str $.medline is rw; 18 | has Str $.pubmed is rw; 19 | has Str $.rp is rw; 20 | has Str $.rg is rw; 21 | has Str $.doi is rw; 22 | 23 | # TODO: This is supposed to return a structured format (YAML/JSON/XML), but 24 | # maybe we need a simple factory for this? Seems like all public atts are 25 | # valid for use here, maybe should be implemented by role 26 | 27 | method hash-tree(){ ... } 28 | 29 | method Str() { 30 | return "Reference: " ~ $.title; 31 | } 32 | 33 | } 34 | -------------------------------------------------------------------------------- /lib/Bio/Annotation/SimpleValue.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::Annotation; 4 | 5 | class Bio::Annotation::SimpleValue does Bio::Role::Annotation { 6 | 7 | has $.value is rw; 8 | 9 | # TODO: This is supposed to return a structured format (YAML/JSON/XML), but 10 | # maybe we need a factory for this? 11 | method hash-tree(){ 12 | return ('value' => self.value); 13 | } 14 | 15 | method Str() { 16 | return "Value: " ~ self.value; 17 | } 18 | 19 | } 20 | -------------------------------------------------------------------------------- /lib/Bio/Grammar/Actions/Default.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | class Fasta::Grammar::Actions { 4 | method Str() { 5 | return ~self.WHAT; 6 | } 7 | method record($/) { 8 | say $/; 9 | } 10 | }; 11 | -------------------------------------------------------------------------------- /lib/Bio/Grammar/Actions/Fasta.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::PrimarySeq; 3 | 4 | class Bio::Grammar::Actions::Fasta { 5 | method TOP($/){ 6 | # #lazy list implementation 7 | # #reason 'for' loops are NOT lazy yet! 8 | # my @matches = gather for @($/) -> $m { 9 | # take $m.ast; 10 | # }; 11 | 12 | # make @matches; 13 | make $/.ast; 14 | } 15 | 16 | method fasta($/){ 17 | 18 | my $id =$/.ast; 19 | my $desc = $/.ast; 20 | 21 | #very basic, does the bare bones for now 22 | my $obj = Bio::PrimarySeq.new(display_id=>$id,description=>$desc,seq=>$/.ast); 23 | make $obj; 24 | } 25 | 26 | method description_line($/){ 27 | make $/; 28 | } 29 | 30 | method sequence($/){ 31 | #turning $/ into a string form of itself 32 | #reason is that subset cannot work directly onto Regex::match 33 | make (~$/).subst("\n", '', :g); 34 | #another way to write it and not sure which way is faster 35 | #make $/.trans(/\n/ => ''); 36 | } 37 | 38 | method id($/) { 39 | make $/; 40 | } 41 | 42 | method description($/){ 43 | make $/; 44 | } 45 | 46 | } 47 | -------------------------------------------------------------------------------- /lib/Bio/Grammar/Actions/SeqDumper.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | class Bio::Grammar::Actions::SeqDumper { 4 | method TOP($/) { } 5 | method Record($/) { } 6 | method Annotation($/) { 7 | say $/ 8 | } 9 | #method AnnotationData($/) { say "Annotation Data:" ~ $/ } 10 | }; 11 | -------------------------------------------------------------------------------- /lib/Bio/Grammar/FTLocation.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | grammar Bio::Grammar::FTLocation { 4 | token TOP { } 5 | 6 | #location ::= | | () 7 | token location { 8 | | 9 | } 10 | 11 | #absolute_location ::= | : 12 | token absolute_location { | } 13 | 14 | token complex_location { '('')' } 15 | 16 | token remote_location { ':' } 17 | 18 | #path ::= :: | 19 | token path { | } 20 | 21 | token database_accession { '::' } 22 | 23 | ##feature_name ::= : | 24 | #token feature_name { ':' | } 25 | # 26 | ##feature_label :== 27 | #token feature_label { + } 28 | 29 | #local_location ::= | | 30 | token local_location { | | } 31 | 32 | #location_list ::= | , 33 | token location_list { [',' ]* } 34 | 35 | #functional_operator ::= 36 | token functional_operator { 'join' | 'order' | 'complement' | 'gap' } 37 | 38 | #base_position ::= | | | 39 | token base_position { | | | | } 40 | 41 | # my addition :) 42 | token abs_base_position { \d+ } 43 | 44 | # low_base_bound ::= > 45 | token low_base_bound { '>' } 46 | 47 | token high_base_bound { '<' } 48 | 49 | # Added, for swissprot seqs 50 | token uncertain_bound { '?' ? } 51 | 52 | # two_base_bound ::= . 53 | token two_base_bound { '('? '.' ')'? } 54 | 55 | # between_position ::= ^ 56 | token between_position { '^' } 57 | 58 | # base_range ::= .. 59 | token base_range { '..' } 60 | 61 | # database ::= 62 | token database { <.symbol>+ } 63 | 64 | # primary_accession ::= 65 | token primary_accession { <.symbol>+ } 66 | 67 | # | | | _ | - | ' | * 68 | token symbol { <.+alpha+digit+[_\-.'*]> } 69 | } 70 | 71 | -------------------------------------------------------------------------------- /lib/Bio/Grammar/Fasta.pm6: -------------------------------------------------------------------------------- 1 | =begin Synopsis 2 | 3 | General grammar for FASTA format. This can be attached to any action (e.g. parse 4 | and index a FASTA file, create a new Bio::PrimarySeq, etc). Original grammar from 5 | Philip Mabon (takadonet) 6 | 7 | =end Synopsis 8 | 9 | use v6; 10 | 11 | grammar Bio::Grammar::Fasta { 12 | token TOP { 13 | ^* 14 | } 15 | token record { 16 | 17 | } 18 | rule description_line { 19 | \>?\n 20 | } 21 | token identifier { 22 | #assume we going to parse NCBI specific id for reference number and gi numbers 23 | \S+ 24 | } 25 | token description { 26 | \N+ 27 | } 28 | rule sequence { 29 | <-[>]>+ 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /lib/Bio/Grammar/GFF.pm6: -------------------------------------------------------------------------------- 1 | =begin Synopsis 2 | 3 | General grammar for GFF v3 format; for older formats we will subclass this 4 | 5 | =end Synopsis 6 | 7 | use v6; 8 | 9 | #use Grammar::Tracer; 10 | 11 | grammar Bio::Grammar::GFF { 12 | 13 | rule TOP { 14 | [ 15 | 16 | ]+ 17 | ? 18 | } 19 | 20 | rule gff-line { 21 | ^^ 22 | [ 23 | | 24 | | 25 | | 26 | ] 27 | $$ 28 | } 29 | 30 | token comment { 31 | '#'<-[#]> <-[\n]>+ 32 | } 33 | 34 | token directive-line { 35 | '##' 36 | 37 | ? 38 | } 39 | 40 | token resolution-line { 41 | '###' 42 | } 43 | 44 | # TODO: break out into handling specific directives 45 | token directive-name { 46 | \S+ 47 | } 48 | 49 | token directive-data { 50 | <-[\n]>+ 51 | } 52 | 53 | token feature-line { 54 | ^^ 55 | \t 56 | \t 57 | \t 58 | \t 59 | \t 60 | \t 61 | \t 62 | \t 63 | 64 | $$ 65 | } 66 | 67 | token reference { 68 | <-[\t]>+ 69 | } 70 | 71 | token source { 72 | <-[\t]>+ 73 | } 74 | 75 | token type { 76 | <-[\t]>+ 77 | } 78 | 79 | token start { 80 | \d+ 81 | } 82 | 83 | token end { 84 | \d+ 85 | } 86 | 87 | token score { 88 | <-[\t]>+ 89 | } 90 | 91 | # TODO: optimize this? 92 | token strand { 93 | < -1 0 1 - + . > 94 | } 95 | 96 | token phase { 97 | <[012\.]> 98 | } 99 | 100 | # TODO: expand into canonical vs custom, URI-encoding, etc.? 101 | token attributes { 102 | + % ';' 103 | } 104 | 105 | token tag-value { 106 | '=' + % ',' 107 | } 108 | 109 | token tag { 110 | <-[\s;=&,]>+ 111 | } 112 | 113 | token value { 114 | <-[\n;=&,]>+ 115 | } 116 | 117 | # not sure if there is a way to use a Grammar within another grammar (yet) 118 | token fasta { 119 | + 120 | } 121 | 122 | token record { 123 | 124 | } 125 | 126 | token description_line { 127 | ^^\> [<.ws> ]? $$ 128 | } 129 | token seq-id { 130 | | 131 | | 132 | } 133 | 134 | token seq-identifier { 135 | \S+ 136 | } 137 | token seq-generic-id { 138 | \S+ 139 | } 140 | 141 | token seq-description { 142 | \N+ 143 | } 144 | token sequence { 145 | <-[>]>+ 146 | } 147 | 148 | } -------------------------------------------------------------------------------- /lib/Bio/Grammar/Genbank.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | #use Grammar::Tracer; 4 | 5 | grammar Bio::Grammar::Genbank { 6 | token TOP { ^+$ } 7 | 8 | token record { 9 | + 10 | ? 11 | } 12 | 13 | token annotation { 14 | ^^ 15 | 16 | .chars == 12 }> # must match exactly 12 chars, could be flexible? 17 | 18 | [\n] 19 | } 20 | 21 | token annotation-col { 22 | \s**0..2 ? <.ws> 23 | } 24 | 25 | token annotation-type { <[A..Z]>+ } 26 | 27 | #token annotation-type { 28 | # [ 29 | # || 30 | # || 31 | # ] 32 | #} 33 | # 34 | ## These could be made stricter (e.g. actual terms) 35 | #token primary-annotation { <[A..Z]>+ } 36 | # 37 | ## These could be made stricter (e.g. actual terms) 38 | #token secondary-annotation { \s**2 <[A..Z]>+ } 39 | 40 | token annotation-data { 41 | \S\N+ # everything not a newline after initial annotation 42 | [ # possibly followed by... 43 | # additional text not possibly matched as annotation 44 | \s**12 45 | \N+ 46 | ]* 47 | } 48 | 49 | token feature-block { ^^ 50 | FEATURES \N+ \n 51 | + 52 | } 53 | 54 | token feature { ^^ 55 | \s**5..* 56 | 57 | <.ws> 58 | 59 | + 60 | } 61 | 62 | token ft-primary-tag { 63 | \S+ 64 | } 65 | 66 | token ft-location-string { 67 | .*? 68 | } 69 | 70 | token ft-tag { 71 | \/ '=' 72 | } 73 | 74 | token ft-tag-key { <-[=]>+ } 75 | 76 | token ft-tag-value { \S\N+ 77 | #[ 78 | #<-[/]> 79 | # \N+ 80 | #]* 81 | } 82 | ##token sequence { .*? } 83 | # 84 | token delimiter { ^^ <[/]>**2 $$ } 85 | }; 86 | -------------------------------------------------------------------------------- /lib/Bio/Location/Simple.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::Location; 4 | use Bio::Type::Location; 5 | 6 | class Bio::Location::Simple does Bio::Role::Location { 7 | 8 | method Str { 9 | my $str = join('', 10 | ?$.seqid ?? $.seqid ~ ':' !! '', 11 | %SYMBOL-TYPE{$.start-pos-type}, 12 | $.start, 13 | %SYMBOL-TYPE{$.type}, 14 | $.end, 15 | %SYMBOL-TYPE{$.end-pos-type}); 16 | } 17 | 18 | } 19 | 20 | -------------------------------------------------------------------------------- /lib/Bio/PrimarySeq.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::Describable; 4 | use Bio::Role::Identifiable; 5 | use Bio::Role::PrimarySeq; 6 | 7 | class Bio::PrimarySeq does Bio::Role::Describable does Bio::Role::Identifiable does Bio::Role::PrimarySeq { } 8 | -------------------------------------------------------------------------------- /lib/Bio/Role/Aliased.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::Aliased { 2 | 3 | # this is a stub for aliasing attributes; aliases are ro for now 4 | # based on a simple aliasing trait by Jonathan Worthington 5 | 6 | multi trait_mod:(Attribute:D $attr, :$aliased!) is export { 7 | my $accessor_name = $attr.name.substr(2); 8 | 9 | # TODO: this only works for class declarations and not roles 10 | for $aliased.list -> $name { 11 | $attr.package.HOW.add_method($attr.HOW, $name, method { 12 | self."$accessor_name"() 13 | } ); 14 | } 15 | } 16 | 17 | } -------------------------------------------------------------------------------- /lib/Bio/Role/Annotatable.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | role Bio::Role::Annotatable { 4 | 5 | has $.annotation-collection; 6 | 7 | } 8 | -------------------------------------------------------------------------------- /lib/Bio/Role/Annotation.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | role Bio::Role::Annotation { 4 | # this creates a set of attributes based on role params 5 | 6 | has Str $.tag-name is rw; 7 | has Str $.tag-term is rw; 8 | 9 | # TODO: This is supposed to return a structured format (YAML/JSON/XML), but 10 | # maybe we need a factory for this? 11 | method hash-tree() { ... } 12 | 13 | method Str() { ... } 14 | 15 | } 16 | -------------------------------------------------------------------------------- /lib/Bio/Role/Describable.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | role Bio::Role::Describable { 4 | 5 | has Str $.display-name is rw = 'new-id'; 6 | has Str $.description is rw; 7 | 8 | } 9 | -------------------------------------------------------------------------------- /lib/Bio/Role/IO.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::Temp; 4 | 5 | role Bio::Role::IO does Bio::Role::Temp { 6 | 7 | # TODO: not sure we need to curry everything here, but list of methods is a rakudo bug 8 | has IO::Handle $.fh; 9 | has $.mode; 10 | 11 | # At the moment we force all IO consumers to initialize-io if they have this 12 | # simple signature 13 | submethod BUILD(:$fh?, :$file?, *%args) { 14 | self.initialize-io(:$fh, :$file, |%args); 15 | } 16 | 17 | # generic IO initializer; more specific ones (e.g. has unique parameter 18 | # settings) should create a new multimethod with a distinct signature and 19 | # run 'nextsame'. See Bio::SeqIO::fasta for an example. 20 | 21 | multi method initialize-io(:$fh?, :$file?, *%args) { 22 | if $file { 23 | for -> $m { 24 | if %args{ $m }:exists and so %args{ $m } { 25 | $!mode ~= $m; 26 | } 27 | } 28 | $!mode //= 'r'; 29 | 30 | # TODO: may want to send explicit list of args to IO (not flattened list of everything) 31 | $!fh = $file.IO.open(|%args) orelse die "Can't open file: $!"; 32 | } 33 | $!fh //= $fh || $*OUT; 34 | } 35 | 36 | # not an attribute!! 37 | method file { 38 | $!fh.path 39 | } 40 | 41 | # only a method that checks the statuus of the IO::Handle; not completely 42 | # implemented but should be soon 43 | 44 | #method mode { 45 | # my $mode; 46 | # given $!fh { 47 | # when .r { 48 | # $mode ~= 'r'; 49 | # proceed; 50 | # } 51 | # when .w { 52 | # $mode ~= 'w'; 53 | # } 54 | # default { 55 | # $mode //= '?'; 56 | # } 57 | # } 58 | # $mode; 59 | #} 60 | 61 | # basically delegates to File::Spec if present, so likely obsolete 62 | method catfile(*@path) { 63 | $*SPEC.catfile(|@path); 64 | } 65 | 66 | method catdir(*@path) { 67 | $*SPEC.catdir(|@path); 68 | } 69 | } 70 | -------------------------------------------------------------------------------- /lib/Bio/Role/Identifiable.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | role Bio::Role::Identifiable { 4 | 5 | # these are the primary data available that are similar to the BioPerl 6 | # Bio::IdentifiableI interface. I've included the primary accession 7 | # (accession) in this implementation, though it may be replaced at some point 8 | 9 | # Do we need other IDs here? Or should we use a simple key-value store with 10 | # custom ID types allowed? 11 | 12 | has Str $.display-id is rw; 13 | has Str $.primary-id is rw; 14 | has Int $.version is rw; 15 | has Str $.authority is rw; 16 | has Str $.namespace is rw; 17 | has Str $.accession is rw; 18 | 19 | method object-id() { 20 | self.accession || ~self 21 | } 22 | 23 | # these latter two methods may be obsoleted 24 | method lsid-string() returns Str { 25 | return join(':', ~self.authority, 26 | ~self.namespace, 27 | ~self.accession || ~self.id || ''); 28 | } 29 | 30 | method namespace-string() returns Str { 31 | return join(':', ~self.namespace, 32 | (~self.accession || ~self.id || '') ~ (~(defined(self.version()) ?? "." ~ self.version !! ''))); 33 | } 34 | 35 | } 36 | 37 | =begin display-id 38 | 39 | Title : display-id 40 | Usage : $string = $obj.display-id() 41 | Function: 42 | Returns : A scalar Str 43 | Status : Virtual 44 | 45 | =end display-id 46 | 47 | =begin object-id 48 | 49 | Title : object-id 50 | Usage : $string = $obj.object-id() 51 | Function: a string which represents the stable primary identifier 52 | in this namespace of this object. For DNA sequences this 53 | is its accession, similarly for protein sequences 54 | Returns : A scalar 55 | Status : Virtual 56 | 57 | =end object-id 58 | -------------------------------------------------------------------------------- /lib/Bio/Role/Location.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::Range; 4 | 5 | use Bio::Type::Location; 6 | 7 | role Bio::Role::Location does Bio::Role::Range { 8 | 9 | has Int $.start-offset is rw = 0; 10 | has Int $.end-offset is rw = 0; 11 | has $.seqid is rw; 12 | has Location-Pos-Type $.start-pos-type is rw = EXACT-POS; 13 | has Location-Pos-Type $.end-pos-type is rw = EXACT-POS; 14 | has Join-Type $.type is rw = EXACT; 15 | 16 | method max-start { 17 | $.start + $.start-offset 18 | } 19 | 20 | method min-start { 21 | $.start 22 | } 23 | 24 | method max-end { 25 | $.end + $.end-offset 26 | } 27 | 28 | method min-end { 29 | $.end 30 | } 31 | 32 | # return Bool 33 | method is-valid returns Bool { 34 | $.start.defined && $.end.defined 35 | and 36 | $.start-pos-type != AFTER 37 | and 38 | $.end-pos-type != BEFORE 39 | } 40 | 41 | method is-remote returns Bool { 42 | $!seqid.defined 43 | } 44 | 45 | method is-fuzzy returns Bool { 46 | $.type != EXACT 47 | or 48 | $.start-pos-type != EXACT-POS 49 | or 50 | $.end-pos-type != EXACT-POS 51 | } 52 | 53 | } 54 | -------------------------------------------------------------------------------- /lib/Bio/Role/Pluggable.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | # This is a stripped-down variation of: 4 | # https://github.com/tony-o/perl6-pluggable/blob/master/lib/Pluggable.pm6 5 | # but parametric and shallow (no recursion) 6 | 7 | # TODO: Do we override the Pluggable role or use our own? Going with our own 8 | # since we make this parameterizable, but it might be nice to use the role... 9 | 10 | role Bio::Role::Pluggable[Str $pd] # does Pluggable 11 | { 12 | has $!plugin-dir = $pd; 13 | 14 | method plugins(:$module) { 15 | my @list; 16 | # if a specific module is passed, check that namespace, otherwise use current class name 17 | my $class = "{$module.defined ?? $module !! ::?CLASS.^name}"; 18 | # convert to path, probably should use spec here 19 | $class ~~ s:g/'::'/\//; 20 | 21 | my $plugin = $!plugin-dir; 22 | 23 | # note this is searching all paths, not needed if a path is given 24 | for ($*REPO) -> $dir { 25 | my Str $start = "{$dir.Str}/$class/$!plugin-dir"; 26 | if $start.IO.d { 27 | for self!search($start, base => $start.chars + 1, baseclass => "{$class}::{$!plugin-dir}::") -> $t { 28 | my $m = $t; 29 | $m ~~ s:g/\//::/; 30 | require ::("$m"); 31 | @list.push($m); 32 | } 33 | } 34 | } 35 | return @list; 36 | } 37 | 38 | method !search(Str $dir, :$baseclass, :$base){ 39 | my @r; 40 | for dir($dir) -> $f { 41 | 42 | next unless $f.IO ~~ :f; 43 | my $modulename = $f.absolute.Str.\ 44 | substr($base).\ 45 | subst(/ '.pm6' $ /, ''); 46 | $modulename ~~ s:g/ [ '/' | '\\' ] /::/; 47 | @r.push("$baseclass$modulename") if $f.IO ~~ :f && $f.basename.match(/ '.pm6' $ /); 48 | } 49 | return @r; 50 | } 51 | } 52 | 53 | -------------------------------------------------------------------------------- /lib/Bio/Role/Range.pm6: -------------------------------------------------------------------------------- 1 | subset RangeTest of Str where .lc eq any ; 2 | 3 | # NOTE: much of this is a direct translation of the Bioperl (v5) class. It could 4 | # be feasibly replaced by something infinitely smarter or even reimplemented 5 | # using Perl 6 Range class (though the benefits may not be immediately obvious 6 | # yet for that). 7 | 8 | role Bio::Role::Range { 9 | 10 | has Int $.start is rw; 11 | has Int $.end is rw; 12 | has Int $.strand is rw; 13 | 14 | method length { 15 | die "Must define both start and end" if !$.start.defined | !$.end.defined; 16 | die "End must be larger than start" if $!start > $!end; 17 | return $.end - $.start + 1; 18 | } 19 | 20 | method overlaps (Bio::Role::Range:D $range, RangeTest :$test = 'ignore') { 21 | (self!teststranded($range, test => $test) && 22 | !(($!start > $range.end || $!end < $range.start))) 23 | } 24 | 25 | method contains (Bio::Role::Range:D $range, RangeTest :$test = 'ignore') { 26 | (self!teststranded($range, :$test) && 27 | $range.start >= $!start && $range.end <= $!end) 28 | } 29 | 30 | method equals (Bio::Role::Range:D $range, RangeTest :$test = 'ignore') { 31 | (self!teststranded($range, :test($test)) && 32 | ($!start == $range.start && $!end == $range.end)) 33 | } 34 | 35 | method !teststranded (Bio::Role::Range $self: Bio::Role::Range:D $r, RangeTest :$test) { 36 | my ($s1, $s2) = ($!strand, $r.strand); 37 | given $test { 38 | when 'ignore' { 39 | # strand doesn't matter 40 | return True 41 | } 42 | when 'weak' { 43 | # strand matters only when set 44 | if $s1 == 0 || $s2 == 0 || $s1 == $s2 { 45 | return True 46 | } 47 | } 48 | when 'strong' { 49 | # strand matters and must be set 50 | if $s1 != 0 && $s1 == $s2 { 51 | return True 52 | } 53 | } 54 | } 55 | return False; 56 | } 57 | 58 | method intersection ( *@ranges, RangeTest :$test = 'ignore') { 59 | my $intersect; 60 | while @ranges > 0 { 61 | $intersect //= self; 62 | 63 | my $compare = @ranges.shift; 64 | 65 | last if !$compare.defined; 66 | 67 | if !$compare!teststranded($intersect, test => $test) { 68 | return; # this returns a Failure (via the signature) 69 | } 70 | 71 | my $start = ($intersect.start, $compare.start).max; # larger of the 2 starts 72 | my $end = ($intersect.end, $compare.end).min; # smaller of the 2 ends 73 | my $intersect_strand = ($intersect.strand == $compare.strand) ?? 74 | $compare.strand !! 0; 75 | 76 | if $start > $end { 77 | return; # this returns a Failure (via the signature) 78 | } else { 79 | $intersect = self.new(start => $start, 80 | end => $end, 81 | strand => $intersect_strand); 82 | } 83 | } 84 | return $intersect; 85 | } 86 | 87 | 88 | 89 | method union (*@ranges, RangeTest :$test = 'ignore') { 90 | my $union_strand = self.strand; # Strand for the union range object. 91 | 92 | #$union_strand = 0 if any(@ranges».strand) != $union_strand; 93 | for @ranges -> $range { 94 | if $range.strand != $union_strand { 95 | $union_strand = 0; 96 | last; 97 | } 98 | } 99 | 100 | my $max = (@ranges, self).flat.max: { $^a.end <=> $^b.end }; 101 | my $min = (@ranges, self).flat.min: { $^a.start <=> $^b.start }; 102 | 103 | # what if the end is undef... 104 | return self.new(start => $min.start, 105 | end => $max.end, 106 | strand => $union_strand); 107 | } 108 | 109 | # this should have a return type of Array of Bio::Role::Range, but NYI 110 | method subtract (Bio::Role::Range $range, RangeTest :$test = 'ignore') { 111 | if !(self!teststranded($range, :$test)) || !self.overlaps($range, :$test) { 112 | return self 113 | } 114 | # Subtracts everything (empty Range of length = 0 and strand = 0 115 | if (self.equals($range, :$test) || $range.contains(self, :$test)) { 116 | return self.new(start => 0, end => 0, strand => 0); 117 | } 118 | 119 | # TODO: oddity with named parameters, see note above 120 | my $int = self.intersection($range, :$test); 121 | 122 | my ($start, $end, $strand) = ($int.start, $int.end, $int.strand); 123 | 124 | #Subtract intersection from $self 125 | my @outranges = (); 126 | if ($!start < $start) { 127 | @outranges.push( 128 | self.new( 129 | start => $!start, 130 | end => $start - 1, 131 | strand => $!strand, 132 | )); 133 | } 134 | if ($!end > $end) { 135 | @outranges.push( 136 | self.new( 137 | start => $end + 1, 138 | end => $!end, 139 | strand => $!strand, 140 | )); 141 | } 142 | return @outranges; 143 | } 144 | 145 | =begin start 146 | 147 | Title : start 148 | Usage : $start = $range.start(); 149 | Function: get/set the start of this range 150 | Returns : the start of this range 151 | Args : optionally allows the start to be set 152 | using $range.start = $start 153 | 154 | =end start 155 | 156 | =begin end 157 | 158 | Title : end 159 | Usage : $end = $range.end(); 160 | Function: get/set the end of this range 161 | Returns : the end of this range 162 | Args : optionally allows the end to be set 163 | using $range.end = $end 164 | 165 | =end end 166 | 167 | =begin length 168 | 169 | Title : length 170 | Usage : $length = $range.length(); 171 | Function: get/set the length of this range 172 | Returns : the length of this range 173 | Args : optionally allows the length to be set 174 | using $range.length = $length 175 | 176 | =end length 177 | 178 | =begin strand 179 | 180 | Title : strand 181 | Usage : $strand = $range.strand; 182 | $range.strand = 1; 183 | Function: get/set the strand of this range 184 | Returns : the strandedness (-1, 0, +1) 185 | Args : optionally allows the strand to be set 186 | using $range->strand($strand) 187 | 188 | =end strand 189 | } -------------------------------------------------------------------------------- /lib/Bio/Role/RecordFormat.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | role Bio::Role::RecordFormat { 4 | 5 | has $.format; 6 | 7 | has $.format-variant; 8 | 9 | has $.format-version; 10 | 11 | method guess-format { ... } 12 | 13 | } -------------------------------------------------------------------------------- /lib/Bio/Role/SeqStream.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | role Bio::Role::SeqStream { 4 | 5 | method next-Seq { ... } 6 | 7 | method write-Seq { ... } 8 | 9 | } -------------------------------------------------------------------------------- /lib/Bio/Role/Temp.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use File::Temp; 4 | 5 | role Bio::Role::Temp { 6 | 7 | has Bool $.cleanup-tempdir = True; 8 | has Bool $.cleanup-tempfiles = True; 9 | has @!tempdirs; 10 | my $tempcounter = 0; 11 | 12 | method tempfile(*%args) { 13 | # local passed arguments should override the global settings, not ignore them 14 | if %args{'unlink'}:!exists { 15 | %args{'unlink'} = False ; 16 | } 17 | return tempfile(|%args); 18 | } 19 | 20 | # a hack for temp directories; a version is working for File::Temp but is stuck 21 | # in a pull request 22 | method tempdir(Bool :$cleanup) { 23 | $!cleanup-tempdir = $cleanup if $cleanup; 24 | my $tdir = $*SPEC.catfile( $*TMPDIR, 25 | sprintf("dir_%s-%s-%s", 26 | %*ENV{'USER'} || 'unknown', 27 | $*PID, 28 | $tempcounter++)); 29 | mkdir($tdir, 0o755); 30 | @!tempdirs.push: $tdir; 31 | return $tdir; 32 | } 33 | 34 | } -------------------------------------------------------------------------------- /lib/Bio/Root/Root.pm6: -------------------------------------------------------------------------------- 1 | class Bio::Root::Root { 2 | 3 | # split up strictness (exceptions) and verbosity (debugging/logging) 4 | has Bool $.verbose is rw = False; 5 | has Int $.strict is rw = 0; 6 | 7 | # not sure we need this yet 8 | method throw (Str $string) { 9 | my $title = "------------- EXCEPTION -------------"; 10 | my $footer = ('-' x $title.chars) ~ "\n"; 11 | die "\n$title\n" ~ "MSG: $string\n" ~ "$footer\n"; 12 | } 13 | 14 | method warn (Str $string) { 15 | if self.verbose == 2 { 16 | return self.throw($string) 17 | } 18 | my $title = "------------- WARNING -------------"; 19 | my $footer = ('-' x $title.chars) ~ "\n"; 20 | if self.verbose >= 0 { 21 | my $msg = "\n$title\n" ~ "MSG: $string\n" ~ "$footer\n"; 22 | # TODO: change to warn(), which is a bit buggy ATM 23 | $*ERR.say($msg); 24 | } 25 | } 26 | 27 | method debug (Str $string? = '') { 28 | ??? $string if self.verbose > 0; 29 | } 30 | 31 | } 32 | -------------------------------------------------------------------------------- /lib/Bio/SeqIO.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::Pluggable; 4 | use Bio::Role::RecordFormat; 5 | use Bio::Role::IO; 6 | 7 | class Bio::SeqIO does Bio::Role::Pluggable['SeqIO'] 8 | does Bio::Role::RecordFormat 9 | #does Bio::Role::IO 10 | { 11 | 12 | has $!plugin handles ; 13 | 14 | submethod BUILD(:$!format, 15 | :$!format-version?, 16 | :$!format-variant?, 17 | *%args) { 18 | 19 | if $!format ~~ / <[-]> / { 20 | ($!format, $!format-variant) = $!format.split: '-', 2; 21 | } else { 22 | $!format = $!format.lc; 23 | } 24 | 25 | my $plugin = "Bio::SeqIO::" ~ $!format; 26 | 27 | try require ::($plugin); 28 | 29 | if ::($plugin) ~~ Failure { 30 | #note(@*INC.join("\t")); 31 | die "Can't load $plugin: $!"; 32 | 33 | } else { 34 | $!plugin = ::($plugin).new(|%args); 35 | } 36 | } 37 | 38 | method guess-format { ... } 39 | } 40 | -------------------------------------------------------------------------------- /lib/Bio/SeqIO/fasta.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Bio::Role::SeqStream; 4 | use Bio::Role::IO; 5 | use Bio::Grammar::Fasta; 6 | use Bio::PrimarySeq; 7 | 8 | class Bio::Grammar::Fasta::Actions::PrimarySeq { 9 | method record($/) { 10 | $/.make( 11 | Bio::PrimarySeq.new( 12 | seq => $.made, 13 | description => $.made // '', 14 | display_id => $.made 15 | ) 16 | ); 17 | } 18 | 19 | method sequence($/) { 20 | $/.make(~$/.subst("\n", '', :g)) 21 | } 22 | } 23 | 24 | class Bio::SeqIO::fasta does Bio::Role::SeqStream does Bio::Role::IO { 25 | has $.buffer is rw; 26 | has $!actions = Bio::Grammar::Fasta::Actions::PrimarySeq.new(); 27 | has $.width = 60; 28 | has $.block = $!width; # NYI 29 | 30 | multi method initialize-io(:$!width?, :$fh?, :$file?, *%args) { 31 | # we reset the input record sep here 32 | callwith(:nl-in("\n>"), :$fh, :$file, |%args); 33 | } 34 | 35 | # TODO: one key future optimization requires implementation in Rakudo: 36 | # 1) Grammar parsing of a stream of data (e.g. Cat), which is now considered 37 | # a post-6.0 update 38 | 39 | # 2) Make next-Seq() a multi, which allows it to take arguments for various iterators 40 | 41 | method next-Seq() { 42 | return if $.fh.eof(); 43 | while $.fh.get -> $chunk { 44 | my ($header, $seq) = $chunk.split("\n", 2); 45 | $header.=subst(/^^\>/, ''); 46 | my ($display_id, $desc) = $header.split(' ', 2); 47 | $seq.=subst("\n", '', :g); 48 | return Bio::PrimarySeq.new( 49 | seq => $seq, 50 | description => $desc || '', 51 | display_id => $display_id 52 | ); 53 | #if $chunk !~~ /^^\>/ { 54 | # return Bio::Grammar::Fasta.parse( ">$chunk", actions => $!actions, rule => 'record').ast; 55 | #} else { 56 | # return Bio::Grammar::Fasta.parse( "$chunk", actions => $!actions, rule => 'record').ast; 57 | #} 58 | } 59 | } 60 | 61 | method write-Seq(Bio::PrimarySeq $seq) { 62 | self.fh.say(sprintf(">%s %s", $seq.display_id, $seq.description)); 63 | self.fh.say($seq.seq.subst( /(.** {$.width})/, { "$0\n" }, :g)); 64 | } 65 | } 66 | -------------------------------------------------------------------------------- /lib/Bio/Tools/FTLocationParser.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | # Using a variation on the old NCBI FT BNF, but perl6-ized 4 | 5 | use Bio::Grammar::FTLocation; 6 | 7 | class Bio::Tools::FTLocationParser { 8 | 9 | my class FTLocation::Actions { 10 | method location($/) { say $/.perl ~ "\n"; } 11 | } 12 | 13 | method from-string(Str $locstr) { 14 | my $loc; 15 | 16 | # grab the AST from the grammar 17 | my $ast = Bio::Grammar::FTLocation.parse($locstr, :actions(FTLocation::Actions)); 18 | 19 | # we can do this lazily and let the class deal with the AST, or create objects 20 | # on the fly (not an easy way to do this lazily currently) 21 | } 22 | 23 | } -------------------------------------------------------------------------------- /lib/Bio/Type/Location.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | #enum Location-Join-Symbol '.', '..', '^'; 4 | 5 | # this could probably be made a trait on start/end 6 | #enum Location-Pos-Symbol '<', '>', '.', '?', '..'; 7 | enum Location-Pos-Type < EXACT-POS BEFORE AFTER WITHIN-POS UNCERTAIN >; 8 | enum Join-Type < EXACT IN-BETWEEN WITHIN >; 9 | enum Split-Location-Type < JOIN ORDER BOND >; 10 | 11 | my %VALID-LOCATION-SYMBOL = 12 | '.' => WITHIN, 13 | '..' => EXACT, 14 | '^' => IN-BETWEEN, 15 | ; 16 | 17 | my %VALID-LOCATION-POS-SYMBOL = 18 | '..' => EXACT-POS, 19 | '<' => BEFORE, 20 | '>' => AFTER, 21 | '.' => WITHIN-POS, 22 | '?' => UNCERTAIN 23 | ; 24 | 25 | our %SYMBOL-TYPE is export = 26 | EXACT => '..', 27 | EXACT-POS => '', 28 | BEFORE => '<', 29 | AFTER => '>', 30 | WITHIN => '.', 31 | WITHIN-POS => '.', 32 | IN-BETWEEN => '^', 33 | UNCERTAIN => '?' 34 | ; 35 | -------------------------------------------------------------------------------- /lib/Bio/Type/Sequence.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | # enum or subset, that is the question... 4 | enum SequenceType ; 5 | -------------------------------------------------------------------------------- /nyi/Bio/Factory/FTLocationFactory.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::Role::Location::Simple; 3 | use Bio::Role::Location::Split; 4 | use Bio::Role::Location::Fuzzy; 5 | class Bio::Factory::FTLocationFactory { 6 | 7 | 8 | method from_string($locstr is copy ,$op?) { 9 | my $loc; 10 | 11 | #self.debug("$locstr\n"); 12 | 13 | # $op for operator (error handling) 14 | 15 | # run on first pass only 16 | # Note : These location types are now deprecated in GenBank (Oct. 2006) 17 | if (!defined($op)) { 18 | # convert all (X.Y) to [X.Y] 19 | # $locstr =~ s{\((\d+\.\d+)\)}{\[$1\]}g; 20 | #probably a rakudo bug that does not allow for the simpler version of the while below 21 | #$locstr ~~ s:g/ \( (\d+\.\d+) \)/\[$0\]/; 22 | while ($locstr ~~ / \( (\d+\.\d+) \) /) { 23 | $locstr ~~ s/ \( (\d+\.\d+) \)/\[$0\]/; 24 | } 25 | 26 | # convert ABC123:(X..Y) to ABC123:[X..Y] 27 | # we should never see the above 28 | # $locstr =~ s{:\((\d+\.{2}\d+)\)}{:\[$1\]}g; 29 | while ($locstr ~~ / \: \( (\d+ \. ** 2 \d+) \)/ ) { 30 | $locstr ~~ s/ \: \( (\d+ \. ** 2 \d+) \) /\:\[$0\]/; 31 | } 32 | 33 | } 34 | 35 | # if ($locstr =~ m{(.*?)\(($LOCREG)\)(.*)}o) { # any matching parentheses? 36 | #not sure if this will get all cases but works for now 37 | if ( $locstr ~~ /(.*?) \( (.*) \) (.*)/ ) { 38 | my ($beg, $mid, $end) = ($0.Str, $1.Str, $2); 39 | my (@sublocs) = (split(',',$beg), $mid, split(',',$end)); 40 | 41 | my @loc_objs; 42 | my $loc_obj; 43 | 44 | while (@sublocs) { 45 | my $subloc = shift @sublocs; 46 | next if !$subloc; 47 | my $oparg = ($subloc eq 'join' || $subloc eq 'bond' || 48 | $subloc eq 'order' || $subloc eq 'complement') ?? $subloc !! Any; 49 | # has operator, requires further work (recurse) 50 | if ($oparg) { 51 | my $sub = shift @sublocs; 52 | # simple split operators (no recursive calls needed) 53 | if (($oparg eq 'join' || $oparg eq 'order' || $oparg eq 'bond' ) 54 | && $sub !~~ /[join|order|bond]/ ) { 55 | my @splitlocs = split(',' , $sub); 56 | 57 | $loc_obj = Bio::Role::Location::Split.new(#verbose => 1, 58 | splittype => $oparg); 59 | while (my $splitloc = shift @splitlocs) { 60 | next unless $splitloc; 61 | my $sobj; 62 | # [^()]+ | \( 63 | # (??{$LOCREG}) 64 | # \) 65 | # if ($splitloc =~ m{\(($LOCREG)\)} ) { 66 | if ($splitloc ~~ / \( (.*?) \) / ) { 67 | my $comploc = $0; 68 | $sobj = self!parse_location($comploc); 69 | $sobj.strand(-1); 70 | } else { 71 | $sobj = self!parse_location($splitloc); 72 | } 73 | $loc_obj.add_sub_Location($sobj); 74 | } 75 | } else { 76 | $loc_obj = self.from_string($sub, $oparg); 77 | # reinsure the operator is set correctly for this level 78 | # unless it is complement 79 | $loc_obj.splittype =$oparg unless $oparg eq 'complement'; 80 | } 81 | } 82 | # no operator, simple or fuzzy 83 | else { 84 | $loc_obj = self.from_string($subloc,1); 85 | } 86 | $loc_obj.strand(-1) if ($op && $op eq 'complement'); 87 | push @loc_objs, $loc_obj; 88 | } 89 | my $ct = @loc_objs; 90 | if ($op && !($op eq 'join' || $op eq 'order' || $op eq 'bond') 91 | && $ct > 1 ) { 92 | # self.throw("Bad operator $op: had multiple locations ". 93 | # scalar(@loc_objs).", should be SplitLocationI"); 94 | } 95 | if ($ct > 1) { 96 | $loc = Bio::Role::Location::Split.new(); 97 | $loc.add_sub_Location(shift @loc_objs) while (@loc_objs); 98 | return $loc; 99 | } else { 100 | $loc = shift @loc_objs; 101 | return $loc; 102 | } 103 | } else { # simple location(s) 104 | $loc = self!parse_location($locstr); 105 | $loc.strand(-1) if (defined $op && $op eq 'complement'); 106 | } 107 | return $loc; 108 | } 109 | 110 | 111 | 112 | method !parse_location($locstr is copy) { 113 | my ($loc, $seqid); 114 | #self.debug( "Location parse, processing $locstr\n"); 115 | # 'remote' location? 116 | if ($locstr ~~ /^(\S+)\:(.*)$/) { 117 | # yes; memorize remote ID and strip from location string 118 | $seqid = $0; 119 | $locstr = $1; 120 | } 121 | 122 | # split into start and end 123 | my ($start, $end) = split(/\.\./, $locstr); 124 | 125 | # remove enclosing parentheses if any; note that because of parentheses 126 | # possibly surrounding the entire location the parentheses around start 127 | # and/or may be asymmetrical 128 | # Note: these are from X.Y fuzzy locations, which are deprecated! 129 | 130 | # $start =~ s/(?:^\[+|\]+$)//g if $start; 131 | $start ~~ s:g/^\[+|\]+// if $start; 132 | $end ~~ s:g/^\[+|\]+// if $end; 133 | # $end =~ s/(?:^\[+|\]+$)//g if $end; 134 | 135 | # Is this a simple (exact) or a fuzzy location? Simples have exact start 136 | # and end, or is between two adjacent bases. Everything else is fuzzy. 137 | my $loctype = ".."; # exact with start and end as default 138 | 139 | $loctype = '?' if ( ($locstr ~~ /\?/) && ($locstr !~~ /\?\d+/) ); 140 | 141 | my $locclass = Bio::Role::Location::Simple; 142 | if (! defined($end)) { 143 | if ($locstr ~~ /(\d+)(<[\.\^]>)(\d+)/) { 144 | $start = $0; 145 | $end = $2; 146 | $loctype = $1; 147 | $locclass = Bio::Role::Location::Fuzzy 148 | unless (abs($end-$start) <= 1) && ($loctype eq "^"); 149 | } else { 150 | $end = $start; 151 | } 152 | } 153 | # start_num and end_num are for the numeric only versions of 154 | # start and end so they can be compared 155 | # in a few lines 156 | my ($start_num, $end_num) = ($start,$end); 157 | if ( ($start ~~ /<[\>\<\?\.\^]>/) || ($end ~~ /<[\>\<\?\.\^]>/) ) { 158 | $locclass = Bio::Role::Location::Fuzzy; 159 | if ($start ~~ /(\d+)/) { 160 | ($start_num) = $0; 161 | } else { 162 | $start_num = 0 163 | } 164 | if ($end ~~ /(\d+)/) { 165 | ($end_num) = $0; 166 | } else { $end_num = 0 } 167 | } 168 | my $strand = 1; 169 | 170 | if ( $start_num > $end_num && $loctype ne '?') { 171 | ($start,$end,$strand) = ($end,$start,-1); 172 | } 173 | # instantiate location and initialize 174 | $loc = $locclass.new(#verbose => self.verbose, 175 | start => $start, 176 | end => $end, 177 | strand => $strand, 178 | location_type => $loctype); 179 | # set remote ID if remote location 180 | if ($seqid) { 181 | $loc.is_remote =1; 182 | $loc.seq_id =$seqid; 183 | } 184 | 185 | # done (hopefully) 186 | return $loc; 187 | } 188 | 189 | 190 | 191 | } 192 | -------------------------------------------------------------------------------- /nyi/Bio/LiveSeq/Mutation.pm6: -------------------------------------------------------------------------------- 1 | class Bio::LiveSeq::Mutation { 2 | #in good time we will finally have a Root 3 | #use base qw(Bio::Root::Root); 4 | 5 | method new(*%args) { 6 | #if len of zero given, we ignore it 7 | if (%args.exists('len') && %args{'len'} == 0 ) { 8 | %args.delete('len'); 9 | } 10 | return self.bless(*,|%args); 11 | } 12 | 13 | # =head2 seq 14 | 15 | # Title : seq 16 | # Usage : $obj.seq(); 17 | # Function: 18 | 19 | # Sets and returns the mutated sequence. No checking is done 20 | # to validate the symbols. 21 | 22 | # Example : 23 | # Returns : string 24 | # Args : integer 25 | 26 | # =cut 27 | 28 | has $!seq is rw; 29 | method seq($value?) { 30 | if ( defined $value) { 31 | $!seq = $value; 32 | } 33 | return $!seq || ''; 34 | } 35 | 36 | 37 | # =head2 seqori 38 | 39 | # Title : seqori 40 | # Usage : $obj.seqori(); 41 | # Function: 42 | 43 | # Sets and returns the original subsequence in the reference 44 | # sequence. No checking is done to validate the symbols. 45 | # Optional value. 46 | 47 | # Example : 48 | # Returns : string 49 | # Args : string 50 | 51 | # =cut 52 | 53 | has $!seqori is rw; 54 | method seqori($value?) { 55 | if ( defined $value) { 56 | $!seqori = $value; 57 | } 58 | return $!seqori || ''; 59 | } 60 | 61 | 62 | # =head2 pos 63 | 64 | # Title : pos 65 | # Usage : $obj.pos(); 66 | # Function: 67 | 68 | # Sets and returns the position of the first element in the 69 | # sequence. 70 | 71 | # Example : 72 | # Returns : string 73 | # Args : integer 74 | 75 | # =cut 76 | 77 | has $!pos is rw; 78 | method pos($value?) { 79 | if ( defined $value) { 80 | if ( $value !~~ /^(<[\+\-]>)? \d+ $/ ) { 81 | die "'$value' for pos has to be an integer"; 82 | self.throw("[$value] for pos has to be an integer\n"); 83 | } else { 84 | $!pos = $value; 85 | } 86 | } 87 | return $!pos; 88 | } 89 | 90 | # =head2 len 91 | 92 | # Title : len 93 | # Usage : $obj.len(); 94 | # Function: 95 | 96 | # Sets and returns the len of the affected original allele 97 | # sequence. If value is not set, defaults to the lenght of 98 | # the mutated sequence (seq). 99 | 100 | # Example : 101 | # Returns : string 102 | # Args : string 103 | 104 | # =cut 105 | has $!len is rw; 106 | 107 | method len($value?) { 108 | if ( defined $value) { 109 | $!len = $value; 110 | } 111 | if ( ! (defined $!len ) ) { 112 | return $!seq.chars; 113 | } 114 | return $!len; 115 | } 116 | 117 | # =head2 label 118 | 119 | # Title : label 120 | # Usage : $obj.label(); 121 | # Function: 122 | 123 | # Sets and returns the label of the affected original allele 124 | # location. Label is a stable identifier whereas location 125 | # can be changed by mutations. Label comes from 126 | # l. 127 | 128 | # Example : 129 | # Returns : string 130 | # Args : string 131 | 132 | # =cut 133 | 134 | has $!label is rw; 135 | method label($value?) { 136 | if ( defined $value) { 137 | $!label = $value; 138 | } 139 | if ( ! defined $!label ) { 140 | return; 141 | } 142 | return $!label; 143 | } 144 | 145 | 146 | # =head2 transpos 147 | 148 | # Title : transpos 149 | # Usage : $obj.transpos(); 150 | # Function: 151 | 152 | # Sets and returns the transcript position of the mutation. 153 | # Set when associated with a reference sequence. Value 154 | # depends on reference molecule and the co-ordinate system 155 | # used. 156 | 157 | # Example : 158 | # Returns : string 159 | # Args : integer 160 | 161 | # =cut 162 | 163 | has $!transpos is rw; 164 | 165 | method transpos($value?) { 166 | if ( defined $value) { 167 | if ( $value !~~ /^ (<[\+\-]>)? \d+ $/ ) { 168 | die "'$value' for transpos has to be an integer"; 169 | # self.throw("[$value] for transpos has to be an integer\n"); 170 | } else { 171 | $!transpos = $value; 172 | } 173 | } 174 | return $!transpos; 175 | } 176 | 177 | 178 | # =head2 issue 179 | 180 | # Title : issue 181 | # Usage : $obj.issue(); 182 | # Function: 183 | 184 | # Sets and returns the position of the mutation in an array 185 | # of mutations to be issued. Set after the validity of the 186 | # mutation has been confirmed. 187 | 188 | # Example : 189 | # Returns : string 190 | # Args : integer 191 | 192 | # =cut 193 | 194 | has $!issue is rw; 195 | method issue($value?) { 196 | if ( defined $value) { 197 | if ( $value !~~ /^(<[\+\-]>)? \d+ $/ ) { 198 | die "'$value' for issue has to be an integer"; 199 | # self.throw("[$value] for issue has to be an integer\n"); 200 | } else { 201 | $!issue = $value; 202 | } 203 | } 204 | return $!issue; 205 | } 206 | 207 | 208 | # =head2 prelabel 209 | 210 | # Title : prelabel 211 | # Usage : $obj.prelabel(); 212 | # Function: 213 | 214 | # Sets and returns the prelabel of the affected original allele 215 | # location. Prelabel is a stable identifier whereas location 216 | # can be changed by mutations. Prelabel comes from 217 | # l. 218 | 219 | # Example : 220 | # Returns : string 221 | # Args : string 222 | 223 | # =cut 224 | 225 | has $!prelabel is rw; 226 | method prelabel($value?) { 227 | if ( defined $value) { 228 | $!prelabel = $value; 229 | } 230 | if ( ! defined $!prelabel ) { 231 | return; 232 | } 233 | return $!prelabel; 234 | } 235 | 236 | 237 | # =head2 postlabel 238 | 239 | # Title : postlabel 240 | # Usage : $obj.postlabel(); 241 | # Function: 242 | 243 | # Sets and returns the postlabel of the affected original allele 244 | # location. Postlabel is a stable identifier whereas location 245 | # can be changed by mutations. Postlabel comes from 246 | # l. 247 | 248 | # Example : 249 | # Returns : string 250 | # Args : string 251 | 252 | # =cut 253 | 254 | has $!postlabel is rw; 255 | method postlabel($value?) { 256 | if ( defined $value) { 257 | $!postlabel = $value; 258 | } 259 | if ( ! defined $!postlabel ) { 260 | return; 261 | } 262 | return $!postlabel; 263 | } 264 | 265 | 266 | # =head2 lastlabel 267 | 268 | # Title : lastlabel 269 | # Usage : $obj.lastlabel(); 270 | # Function: 271 | 272 | # Sets and returns the lastlabel of the affected original allele 273 | # location. Lastlabel is a stable identifier whereas location 274 | # can be changed by mutations. Lastlabel comes from 275 | # l. 276 | 277 | # Example : 278 | # Returns : string 279 | # Args : string 280 | 281 | # =cut 282 | 283 | has $!lastlabel is rw; 284 | method lastlabel($value?) { 285 | if ( defined $value) { 286 | $!lastlabel = $value; 287 | } 288 | if ( ! defined $!lastlabel ) { 289 | return; 290 | } 291 | return $!lastlabel; 292 | } 293 | 294 | } 295 | 296 | # # $Id: Mutation.pm 16123 2009-09-17 12:57:27Z cjfields $ 297 | # # 298 | # # BioPerl module for Bio::LiveSeq::Mutation 299 | # # 300 | # # Please direct questions and support issues to 301 | # # 302 | # # Cared for by Heikki Lehvaslaiho 303 | # # 304 | # # Copyright Heikki Lehvaslaiho 305 | # # 306 | # # You may distribute this module under the same terms as perl itself 307 | 308 | # # POD documentation - main docs before the code 309 | 310 | # =head1 NAME 311 | 312 | # Bio::LiveSeq::Mutation - Mutation event descriptor class 313 | 314 | # =head1 SYNOPSIS 315 | 316 | # # full descrition of a point mutation 317 | # $mutation1a = Bio::LiveSeq::Mutation.new ( -seq => 'A', 318 | # -seqori => 'T', 319 | # -pos => 100, 320 | # -len => 1 # optional, defaults to length(seq) 321 | # ); 322 | 323 | # # minimal information for a point mutation 324 | # $mutation1b = Bio::LiveSeq::Mutation.new ( -seq => 'A', 325 | # -pos => 100 326 | # ); 327 | # # insertion 328 | # $mutation2 = Bio::LiveSeq::Mutation.new ( -seq => 'ATT', 329 | # -pos => 100, 330 | # -len => 0 331 | # ); 332 | # # deletion 333 | # $mutation3 = Bio::LiveSeq::Mutation.new ( -seq => '', # optional 334 | # -seqori => 'TTG', # optional 335 | # -pos => 100 336 | # -len => 3 337 | # ); 338 | # # complex 339 | # $mutation4 = Bio::LiveSeq::Mutation.new ( -seq => 'CC', 340 | # -seqori => 'TTG', # optional 341 | # -pos => 100 342 | # -len => 3 343 | # ); 344 | 345 | 346 | # =head1 DESCRIPTION 347 | 348 | # This class describes a local mutation event using minimalistic 349 | # description. It is not necessary to know anything about the original 350 | # sequence. You need to give the changed sequence, the position of the 351 | # mutation in the (unidentified) reference sequence, and the length of 352 | # the affected subsequence in the reference sequence. If the original 353 | # allele sequence is given, the objects applying the mutation into the 354 | # reference sequence (e.g. L) might check for its 355 | # validity. 356 | 357 | # =head1 FEEDBACK 358 | 359 | # =head2 Mailing Lists 360 | 361 | # User feedback is an integral part of the evolution of this and other 362 | # Bioperl modules. Send your comments and suggestions preferably to the 363 | # Bioperl mailing lists Your participation is much appreciated. 364 | 365 | # bioperl-l@bioperl.org - General discussion 366 | # http://bioperl.org/wiki/Mailing_lists - About the mailing lists 367 | 368 | # =head2 Support 369 | 370 | # Please direct usage questions or support issues to the mailing list: 371 | 372 | # I 373 | 374 | # rather than to the module maintainer directly. Many experienced and 375 | # reponsive experts will be able look at the problem and quickly 376 | # address it. Please include a thorough description of the problem 377 | # with code and data examples if at all possible. 378 | 379 | # =head2 Reporting Bugs 380 | 381 | # report bugs to the Bioperl bug tracking system to help us keep track 382 | # the bugs and their resolution. Bug reports can be submitted via the 383 | # web: 384 | 385 | # http://bugzilla.open-bio.org/ 386 | 387 | # =head1 AUTHOR - Heikki Lehvaslaiho 388 | 389 | # Email: heikki-at-bioperl-dot-org 390 | 391 | # =head1 APPENDIX 392 | 393 | # The rest of the documentation details each of the object 394 | # methods. Internal methods are usually preceded with a _ 395 | 396 | # =cut 397 | -------------------------------------------------------------------------------- /nyi/Bio/Role/AnnotationCollection.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::AnnotationCollection { 2 | # rakudo doesn't handle typed arrays yet for return values, this can be done in the 3 | 4 | our method get_all_Annotation_keys returns Array of Str {...} 5 | 6 | our method get_Annotations returns Array of Bio::Role::Annotation (:@tagname? of Str) {...} 7 | 8 | our method get_nested_Annotations returns Array of Bio::Role::Annotation (:@tagname? of Str) {...} 9 | 10 | our method get_all_Annotations returns Array of Bio::Role::Annotation (:@tagname? of Str) {...} 11 | 12 | our method get_num_Annotations returns Array (Str :$tagname?) {...} 13 | 14 | our method add_Annotation returns Bool (Str :$tagname?, Bio::Role::Annotation *@annotations) {...} 15 | 16 | our method remove_Annotations returns Bio::Role::Annotation (:@tagname of Str) {...} 17 | 18 | our method flatten_Annotations returns Array of Bio::Role::Annotation (:@tagname of Str) {...} 19 | } 20 | -------------------------------------------------------------------------------- /nyi/Bio/Role/FastaIO.pm6: -------------------------------------------------------------------------------- 1 | use Bio::Grammar::Fasta; 2 | use Bio::Grammar::Actions::Fasta; 3 | use Bio::Role::IO; 4 | 5 | role Bio::Role::FastaIO[$file] does Bio::Role::IO[$file]{ 6 | 7 | has Int $!width=80; 8 | has $!fh; 9 | 10 | method next_seq() { 11 | my $record= self.next_record(); 12 | if (defined $record) { 13 | return Bio::Grammar::Fasta.parse($record, :actions(Bio::Grammar::Actions::Fasta)).ast; 14 | } 15 | return Any; 16 | } 17 | 18 | 19 | method initial_write() { 20 | #need error checking to ensure that we did indeed open a new file 21 | 22 | if $file.WHAT ~~ IO { 23 | $!fh = $file; 24 | } 25 | else { 26 | $!fh = open($file,:w); 27 | } 28 | } 29 | 30 | method write_seq(*@seq){ 31 | 32 | for @seq -> $seq { 33 | #need to ensure we have Bio::PrimarySeqI 34 | 35 | #most raw way to print out fasta files with no options whatsoever 36 | my $header = ">$seq.display_id() $seq.description()"; 37 | 38 | my $sequence = $seq.seq().comb( /. ** {1..$!width}/).join("\n"); 39 | 40 | $!fh.say($header ~ "\n" ~ $sequence); 41 | 42 | } 43 | 44 | } 45 | 46 | } 47 | -------------------------------------------------------------------------------- /nyi/Bio/Role/Feature.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::Feature { 2 | # This is a generic role that describes and manipulates a specific region or 3 | # segment that can be mapped to a start/end (and possibly strand) within another 4 | # instance. In most cases the other instance will be a sequence, but it can also 5 | # be used to describe a section in an alignment (such as a consensus structure), 6 | # etc. If properly abused it could possibly be made to describe portions of a 7 | # tree, where start and end denote start/end nodes. 8 | 9 | # Modules using this role may or may not also be a FeatureHolder, and that 10 | # these methods should not rely on that Role being implemented (or should at 11 | # least take the above into consideration and DTRT) 12 | 13 | # display_name() could come in from Bio::Role::Describe, which also brings in 14 | # description() 15 | 16 | # Tags may or may not be mapped to a Bio::Role::AnnotationCollection (TBD)s 17 | # we could implement it so that Bio::Role::AnnotationCollection does everything 18 | # lazily; if you add a tag, the simple tag value is added (and not a heavier 19 | # Bio::Role::Annotation) whereas if you add a Bio::Role::Annotation it is used 20 | # instead. 21 | 22 | qw( 23 | display_name 24 | primary_tag 25 | source_tag 26 | score 27 | has_tag 28 | add_tag_values 29 | get_tag_values 30 | get_tagset_values 31 | get_all_tags 32 | remove_tag 33 | 34 | splice 35 | attach_instance 36 | get_trunc_instance 37 | entire_instance 38 | instance_id 39 | 40 | location 41 | primary_id 42 | set_attributes 43 | ); 44 | 45 | # seq-specific, should delegate to the generic method, which just curries 46 | # trunc() (or whatever method name we intend on using for getting a slice of an 47 | # object) 48 | 49 | # the call to trunc() should allow for optional recursive calls to contained 50 | # objects 51 | 52 | # subrole-specific attributes should be mappable to the tag system above (such 53 | # as frame() below), primarily so that persisting the data is done in a 54 | # consistent way, using the most generic Role vs the most specific one 55 | 56 | # seq-specific 57 | 58 | qw( 59 | spliced_Seq 60 | get_Seq 61 | attach_Seq 62 | entire_Seq 63 | frame 64 | ); 65 | 66 | # alignment-specific 67 | 68 | qw( 69 | spliced_Aln 70 | get_Aln 71 | attach_Aln 72 | entire_Aln 73 | ); 74 | 75 | # Tree-specific 76 | 77 | qw( 78 | spliced_Tree 79 | get_Tree 80 | attach_Tree 81 | entire_Tree 82 | ); 83 | } 84 | -------------------------------------------------------------------------------- /nyi/Bio/Role/FeatureCollection.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::FeatureCollection { 2 | # this role describes methods for accessing Features for a specific instance. 3 | # implementing classes are considered to contain Bio::Role::Features of some 4 | # type. 5 | 6 | # Wondering if this and FeatureHolder should be combined for 7 | # consistency. For instance, it would be nice to have binning available for 8 | # grabbing features by location. May be redundant for subfeatures... 9 | 10 | # Would be nice to have iterative methods. Built-in support for Iterators and 11 | # laziness are planned for perl6 (Iterators are to be a built-in Role): 12 | 13 | # http://design.perl6.org/S07.html 14 | 15 | # Also note that having Grammars that we can attach various Actions to may 16 | # help this quite a bit. We'll see as the spec develops... 17 | 18 | has Int $.min_bin; 19 | has Int $.max_bin; 20 | 21 | our Array of Bio::Role::Feature method get_Features 22 | ( 23 | :$range? of any(Range | Bio::Role::Range), # for grabbing features in a range 24 | Int :$start?, 25 | Int :$end?, 26 | Int :$strand?, 27 | Bool :$contains?, 28 | Str :$strand_test?, 29 | ) 30 | {...} 31 | 32 | our Bool method add_Features (:@features of Bio::Role::Feature) 33 | {...} 34 | 35 | our Array of Bio::Role::Features remove_Features 36 | ( 37 | :@features? of Bio::Role::Feature, 38 | :$range? of any(Range | Bio::Role::Range) 39 | ) 40 | {...} 41 | 42 | our Int method feature_count 43 | {...} 44 | 45 | our Array of Bio::Role::Feature method get_all_Features 46 | {...} 47 | } 48 | -------------------------------------------------------------------------------- /nyi/Bio/Role/IO.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::IO[$file]{ 2 | has @!records is rw; 3 | 4 | method next_record(){ 5 | shift @!records; 6 | } 7 | 8 | method !set_io(Bool $keep_sep? ,Str :$separator where { $separator.chars == 1 } ) { 9 | @!records := gather { 10 | #rakudo specific code, hopefully it will go away soon 11 | my $in = pir::open__PSS($file, 'r'); 12 | $in.record_separator($separator); 13 | ### 14 | 15 | my $x = $in.readline(); 16 | 17 | #if we did not find $separator at the end, then there is no record at all 18 | if ($x !~~ /$separator$/) { 19 | take ''; 20 | return; 21 | } 22 | 23 | while ($x = $in.readline()) { 24 | 25 | #check to see if it's at the end of a record. 26 | if ($x !~~ /\n$separator$/) { 27 | my $next; 28 | #if not, readline another line till we hit the end of the record or EOF 29 | repeat { 30 | $next = $in.readline(); 31 | $x ~= $next; 32 | } while $x !~~ /\n$separator$/ && $next ne ''; 33 | } 34 | 35 | #remove trailing '>' and append to the beginning of the record 36 | $x = $x.subst(/$separator$/,''); 37 | #append to the beginning of the record 38 | $x = $separator ~ $x; 39 | take $x; 40 | } 41 | 42 | } 43 | 44 | } 45 | 46 | 47 | } 48 | -------------------------------------------------------------------------------- /nyi/Bio/Role/Location.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::Location { 2 | #probably add range in time 3 | #does Bio::Role::Range; 4 | 5 | has Str $.seq_id is rw; 6 | has Bool $.is_remote is rw = False; 7 | 8 | #will be type of : Location_Pos_Type 9 | has Str $.start_pos_type is rw = 'EXACT'; 10 | has Str $.end_pos_type is rw = 'EXACT'; 11 | 12 | #need to be Location_Type obj 13 | has Str $.location_type is rw = 'EXACT'; 14 | 15 | 16 | 17 | #need to be Sequence_strand Obj 18 | has Str $!strand is rw = 0; 19 | 20 | 21 | multi method flip_strand() { 22 | $!strand = $!strand * -1; 23 | } 24 | 25 | multi method strand(){ 26 | return $!strand; 27 | } 28 | 29 | multi method strand($value){ 30 | $!strand=$value; 31 | } 32 | 33 | multi method each_Location($order?) { 34 | return self; 35 | } 36 | 37 | 38 | # below should be the interface 39 | # # thinking the below could possibly be flattened into Location or Range 40 | # # via curry/assuming? 41 | # probably not doing CoordinatePolicy 42 | # has Bio::Role::CoordinatePolicy $.coordinate_policy is rw; 43 | 44 | # not sure how I'm going to handle this yet 45 | # our Int method min_start {...} 46 | # our Int method max_start {...} 47 | # our Int method min_end {...} 48 | # our Int method max_end {...} 49 | # our Str method start_pos_type {...} 50 | # our Str method end_pos_type {...} 51 | # our method flip_strand {...} 52 | 53 | # our Str to_string {...} 54 | # our Bio::Role::Location next_Location {...} 55 | # our Bool method is_valid {...} 56 | } 57 | -------------------------------------------------------------------------------- /nyi/Bio/Role/Location/Fuzzy.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::Role::Location; 3 | 4 | role Bio::Role::Location::Fuzzy does Bio::Role::Location { 5 | has Int $.minstart is rw; 6 | has Int $.maxstart is rw; 7 | 8 | has Int $.minend is rw; 9 | has Int $.maxend is rw; 10 | 11 | our %FUZZYCODES = ( 'EXACT' => '..', # Position is 'exact 12 | # Exact position is unknown, but is within the range specified, ((1.2)..100) 13 | 'WITHIN' => '.', 14 | # 1^2 15 | 'BETWEEN' => '^', 16 | 'IN-BETWEEN' => '^', 17 | 'UNCERTAIN' => '?', 18 | # <100 19 | 'BEFORE' => '<', 20 | # >10 21 | 'AFTER' => '>'); 22 | 23 | 24 | 25 | our %strands_switch = ('+' => 1 , '-' => -1); 26 | 27 | our %RANGEENCODE = ('..' => 'EXACT', '.' => 'WITHIN', '?' => 'UNCERTAIN', 28 | '^' => 'IN-BETWEEN' ); 29 | 30 | our %RANGEDECODE = ('EXACT' => '..', 'WITHIN' => '.', 'UNCERTAIN' => '?', 31 | 'IN-BETWEEN' => '^' ); 32 | 33 | our %POSTYPEENCODE = ('<' => 'BEFORE', 34 | '>' => 'AFTER'); 35 | 36 | our %POSTYPEDECODE = ('BEFORE' => '<', 37 | 'AFTER' => '>'); 38 | ######################################### 39 | 40 | method new(*%params is copy){ 41 | #fuzzy do not have start, they have minstart and/or maxstart 42 | if ( %params.exists('start')) { 43 | %params{'minstart'}=%params{'start'}; 44 | %params.delete('start'); 45 | } 46 | 47 | #fuzzy do not have end, they have minend and/or maxend 48 | if ( %params.exists('end')) { 49 | %params{'maxend'}=%params{'end'}; 50 | %params.delete('end'); 51 | } 52 | 53 | my $x = self.bless(*,|%params); 54 | #parameter checking that should go away when subtypes work with attributes 55 | #swapping out '+' and '-' for integers in strand 56 | if ( %strands_switch.exists($x.strand)) { 57 | $x.strand = %strands_switch{%params{'strand'}}; 58 | } 59 | 60 | #swapping out '..' and '^' for words in location_type 61 | if ( %RANGEENCODE.exists($x.location_type)) { 62 | $x.location_type = %RANGEENCODE{%params{'location_type'}}; 63 | } 64 | 65 | #swapping out '<' and '>' for words in start/end pos type 66 | if ( %POSTYPEENCODE.exists($x.start_pos_type)) { 67 | $x.start_pos_type = %POSTYPEENCODE{%params{'start_pos_type'}}; 68 | } 69 | if ( %POSTYPEENCODE.exists($x.end_pos_type)) { 70 | $x.end_pos_type = %POSTYPEENCODE{%params{'end_pos_type'}}; 71 | } 72 | 73 | #checking for fuzzy stuff here 74 | if ( %params.exists('minstart') ) { 75 | my ($encode,$min,$max) = self!fuzzypointdecode(%params{'minstart'}); 76 | $x.start_pos_type = $encode; 77 | $x.minstart = $min; 78 | $x.maxstart = $max; 79 | } 80 | 81 | if ( %params.exists('maxend') ) { 82 | my ($encode,$min,$max) = self!fuzzypointdecode(%params{'maxend'}); 83 | $x.end_pos_type = $encode; 84 | $x.minend = $min; 85 | $x.maxend = $max; 86 | } 87 | 88 | return $x; 89 | } 90 | 91 | multi method start($value?) { 92 | if ( defined $value ) { 93 | my ($encode,$min,$max) = self!fuzzypointdecode($value); 94 | self.start_pos_type = $encode; 95 | self.min_start($min); 96 | self.max_start($max); 97 | } 98 | 99 | # $self->throw("Use Bio::Location::Simple for IN-BETWEEN locations [" 100 | # . $self->SUPER::start. "] and [". $self->SUPER::end. "]") 101 | # if $self->location_type eq 'IN-BETWEEN' && defined $self->SUPER::end && 102 | # ($self->SUPER::end - 1 == $self->SUPER::start); 103 | 104 | #if minstart not defined, take maxstart 105 | return $.minstart ?? $.minstart !! $.maxstart; 106 | } 107 | 108 | 109 | method end($value?) { 110 | if ( defined $value ) { 111 | my ($encode,$min,$max) = self!fuzzypointdecode($value); 112 | self.end_pos_type =$encode; 113 | self.min_end($min); 114 | self.max_end($max); 115 | } 116 | 117 | # $self->throw("Use Bio::Location::Simple for IN-BETWEEN locations [". 118 | # $self->SUPER::start. "] and [". $self->SUPER::end. "]") 119 | # if $self->location_type eq 'IN-BETWEEN' && defined $self->SUPER::start && 120 | # ($self->SUPER::end - 1 == $self->SUPER::start); 121 | 122 | return $.maxend ?? $.maxend !! $.minend; 123 | } 124 | 125 | 126 | method min_start($value?){ 127 | if ( defined $value) { 128 | $.minstart = $value; 129 | } 130 | 131 | return Any if !$.minstart || (self.start_pos_type eq 'BEFORE'); 132 | return $.minstart; 133 | } 134 | 135 | method max_start($value?){ 136 | if ( defined $value) { 137 | $.maxstart = $value; 138 | } 139 | return $.maxstart; 140 | } 141 | 142 | method max_end($value?) { 143 | if ( defined $value ) { 144 | $.maxend = $value; 145 | } 146 | return Any if !$.maxend || (self.end_pos_type eq 'AFTER'); 147 | return $.maxend; 148 | } 149 | 150 | method min_end($value?) { 151 | if ( defined $value) { 152 | $.minend = $value; 153 | } 154 | return $.minend; 155 | } 156 | 157 | 158 | # submethod BUILD(*%params is copy) { 159 | # # RAKUDO: These attributes should be auto-initialized but are not 160 | # $!start = %params.exists('start') ?? %params{'start'} !! 0; 161 | # $!end = %params.exists('end') ?? %params{'end'} !! 0 ; 162 | # $.seq_id = %params{'seq_id'}; 163 | # $.is_remote = %params.exists('is_remote') ?? %params{'is_remote'} !! False; 164 | # $.start_pos_type = %params.exists('start_pos_type') ?? %params{'start_pos_type'} !! 'EXACT'; 165 | # $.end_pos_type = %params.exists('end_pos_type') ?? %params{'end_pos_type'} !! 'EXACT'; 166 | # $.location_type = %params.exists('location_type') ?? %params{'location_type'} !! 'EXACT'; 167 | 168 | # $!strand = %params.exists('strand') ?? %params{'strand'} !! 0; 169 | # $.start_offset = %params.exists('start_offset') ?? %params{'start_offset'} !! 0; 170 | # $.end_offset = %params.exists('end_offset') ?? %params{'end_offset'} !! 0 ; 171 | 172 | 173 | # # self.start(%params{'start'}); 174 | # # self.end(%params{'end'}); 175 | # } 176 | 177 | 178 | 179 | method to_FTstring() { 180 | my (%vals) = ( 'start' => self.start, 181 | 'min_start' => self.min_start, 182 | 'max_start' => self.max_start, 183 | 'start_code' => self.start_pos_type, 184 | 'end' => self.end, 185 | 'min_end' => self.min_end, 186 | 'max_end' => self.max_end, 187 | 'end_code' => self.end_pos_type ); 188 | 189 | my (%strs) = ( 'start' => '', 190 | 'end' => ''); 191 | my ($delimiter) = %FUZZYCODES{self.location_type}; 192 | $delimiter = %FUZZYCODES{'EXACT'} if (self.location_type eq 'UNCERTAIN'); 193 | 194 | 195 | # I'm lazy, lets do this in a loop since behaviour will be the same for 196 | # start and end 197 | for ( qw ) -> $point { 198 | if ( (%vals{$point ~ "_code"} ne 'EXACT') && 199 | (%vals{$point ~ "_code"} ne 'UNCERTAIN') ) { 200 | 201 | # must have max and min defined to use 'WITHIN', 'BETWEEN' 202 | if ((!defined %vals{"min_$point"} || 203 | !defined %vals{"max_$point"}) && 204 | ( %vals{$point ~ "_code"} eq 'WITHIN' || 205 | %vals{$point ~ "_code"} eq 'BETWEEN')) 206 | { 207 | %vals{"min_$point"} = '' unless defined %vals{"min_$point"}; 208 | %vals{"max_$point"} = '' unless defined %vals{"max_$point"}; 209 | 210 | # $self->warn("Fuzzy codes for start are in a strange state, (". 211 | # join(",", (%vals{"min_$point"}, 212 | # %vals{"max_$point"}, 213 | # %vals{$point."_code"})). ")"); 214 | return ''; 215 | } 216 | 217 | if (defined %vals{$point ~ "_code"} && 218 | (%vals{$point ~ "_code"} eq 'BEFORE' || 219 | %vals{$point ~ "_code"} eq 'AFTER')) 220 | { 221 | %strs{$point} ~= %FUZZYCODES{%vals{$point ~ "_code"}}; 222 | %strs{$point} ~= %vals{"$point"}; 223 | } 224 | 225 | if ( defined %vals{$point ~ "_code"} && 226 | (%vals{$point ~ "_code"} eq 'WITHIN' || 227 | %vals{$point ~ "_code"} eq 'BETWEEN')) 228 | { 229 | # Expect odd results with anything but WidestCoordPolicy for now 230 | %strs{$point} ~= ($point eq 'start') ?? 231 | %vals{"$point"} ~ 232 | %FUZZYCODES{%vals{$point ~ "_code"}} ~ 233 | %vals{'max_' ~ $point} 234 | !! 235 | %vals{'min_' ~ $point} ~ 236 | %FUZZYCODES{%vals{$point ~ "_code"}} ~ 237 | %vals{"$point"}; 238 | %strs{$point} = "(" ~ %strs{$point} ~ ")"; 239 | } 240 | 241 | } elsif (%vals{$point ~ "_code"} eq 'UNCERTAIN') { 242 | %strs{$point} = %FUZZYCODES{%vals{$point ~ "_code"}}; 243 | %strs{$point} ~= %vals{$point} if defined %vals{$point}; 244 | } else { 245 | %strs{$point} = %vals{$point}; 246 | } 247 | } 248 | 249 | my $str = %strs{'start'} ~ $delimiter ~ %strs{'end'}; 250 | if (self.is_remote() && self.seq_id()) { 251 | $str = self.seq_id() ~ ":" ~ $str; 252 | } 253 | if ( defined self.strand && 254 | self.strand == -1 && 255 | self.location_type() ne "UNCERTAIN") { 256 | $str = "complement(" ~ $str ~ ")"; 257 | } elsif (self.location_type() eq "WITHIN") { 258 | $str = "(" ~ $str ~ ")"; 259 | } 260 | 261 | return $str; 262 | } 263 | 264 | 265 | multi method !fuzzypointdecode() { 266 | return (); 267 | } 268 | 269 | multi method !fuzzypointdecode($string is copy) { 270 | 271 | # strip off leading and trailing space 272 | $string = $string.trim(); 273 | 274 | #need to flip this around since rx are not just string anymore! they are code blocks 275 | #will have issue since we have two BEFORE keys.. 276 | my %FUZZYPOINTENCODE = ( 277 | 278 | # '(.{0})(\d+)\<' => 'BEFORE', 279 | # 'BEFORE' => rx{('')(\d+)\<}, 280 | 'BEFORE' => rx{^\<('')(\d+)$}, 281 | 'EXACT'=> rx{^(\d+)$}, 282 | 'UNCERTAIN' => rx{\?(\d*)}, 283 | 'AFTER' => rx{^[(\d+)\>|\>(\d+)]$}, 284 | # '\>(\d+)(.{0})' => 'AFTER', 285 | #'AFTER' => rx{^\>(\d+)$}, 286 | 'WITHIN' => rx{(\d+)\.(\d+)} , 287 | 'BETWEEN' => rx{(\d+)\^(\d+)} 288 | ); 289 | 290 | 291 | for ( %FUZZYPOINTENCODE.kv ) -> $type,$pattern { 292 | if ( $string ~~ $pattern ) { 293 | my ($min,$max) = ($0.Str.Int,$1.Str.Int) unless (($0 eq '') && (!defined $1)); 294 | if ( ($type eq 'EXACT') || 295 | ($type eq 'UNCERTAIN') 296 | ) { 297 | $max = $min; 298 | } else { 299 | $max = Any if ((defined $max) && ($max.chars == 0)); 300 | $min = Any if ((defined $min) && ($min.chars == 0)); 301 | } 302 | return ($type,$min,$max); 303 | } 304 | } 305 | # if ( $self->verbose >= 1 ) { 306 | # $self->warn("could not find a valid fuzzy encoding for $string"); 307 | # } 308 | return (); 309 | } 310 | 311 | 312 | } 313 | -------------------------------------------------------------------------------- /nyi/Bio/Role/Location/Simple.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::Role::Location; 3 | 4 | role Bio::Role::Location::Simple does Bio::Role::Location { 5 | has Int $.start is rw = 0; 6 | has Int $.end is rw = 0; 7 | 8 | #no spec on if we are keeping this or not. Bioperl-live does not have these however biome does 9 | #this is for 'fuzzy' locations like WITHIN, BEFORE, AFTER 10 | has Int $.start_offset is rw = 0; 11 | has Int $.end_offset is rw = 0; 12 | 13 | 14 | has %!IS_FUZZY = map {;$_ => 1} , qw; 15 | 16 | 17 | 18 | #really want to get rid of all the hashes below 19 | #however cannot since subtype do not WORK with attributes! 20 | #strand switch since we allow '+' and '-' 21 | our %strands_switch = ('+' => 1 , '-' => -1); 22 | 23 | our %RANGEENCODE = ('..' => 'EXACT', 24 | '^' => 'IN-BETWEEN' ); 25 | 26 | our %RANGEDECODE = ('EXACT' => '..', 27 | 'IN-BETWEEN' => '^' ); 28 | 29 | our %POSTYPEENCODE = ('<' => 'BEFORE', 30 | '>' => 'AFTER'); 31 | 32 | our %POSTYPEDECODE = ('BEFORE' => '<', 33 | 'AFTER' => '>'); 34 | ######################################### 35 | 36 | method new(*%params){ 37 | my $x = self.bless(*,|%params); 38 | #parameter checking that should go away when subtypes work with attributes 39 | #swapping out '+' and '-' for integers in strand 40 | if ( %strands_switch.exists($x.strand)) { 41 | $x.strand = %strands_switch{%params{'strand'}}; 42 | } 43 | 44 | #swapping out '..' and '^' for words in location_type 45 | if ( %RANGEENCODE.exists($x.location_type)) { 46 | $x.location_type = %RANGEENCODE{%params{'location_type'}}; 47 | } 48 | 49 | #swapping out '<' and '>' for words in start/end pos type 50 | if ( %POSTYPEENCODE.exists($x.start_pos_type)) { 51 | $x.start_pos_type = %POSTYPEENCODE{%params{'start_pos_type'}}; 52 | } 53 | if ( %POSTYPEENCODE.exists($x.end_pos_type)) { 54 | $x.end_pos_type = %POSTYPEENCODE{%params{'end_pos_type'}}; 55 | } 56 | 57 | #checking for fuzzy stuff here 58 | if ( %params.exists('start') && %params{'start'} ~~ /\<(\d+)/) { 59 | $x.start ~~ s/\ $x { 71 | %data{$x.name} = $x.get_value(self); 72 | } 73 | 74 | for qw<$!start $!end> -> $pos { 75 | my $pos_str = %data{$pos} || ''; 76 | if ($pos eq 'end' && %data{'$!start'} == %data{'$!end'}) { 77 | $pos_str = ''; 78 | } 79 | given (%data{"$pos" ~ '_pos_type'}) { 80 | when ('WITHIN') { 81 | $pos_str = '(' ~ %data{"$!min_$pos"} ~ '.' ~ %data{"$!max_$pos"} ~ ')'; 82 | } 83 | when ('BEFORE') { 84 | $pos_str = '<' ~ $pos_str; 85 | } 86 | when ('AFTER') { 87 | $pos_str = '>' ~ $pos_str; 88 | } 89 | when ('UNCERTAIN') { 90 | $pos_str = '?' ~ $pos_str; 91 | } 92 | } 93 | %data{"$pos" ~ "_string"} = $pos_str; 94 | } 95 | 96 | my $str = %data{'$!start_string'} ~ (%data{'$!end_string'} ?? 97 | %RANGEDECODE{%data{'$!location_type'}} ~ 98 | %data{'$!end_string'} !! ''); 99 | $str = "%data{'$!seq_id'}:$str" if %data{'$!seq_id'} && %data{'$!is_remote'}; 100 | $str = "($str)" if %data{'$!location_type'} eq 'WITHIN'; 101 | if (self.strand == -1) { 102 | $str = sprintf("complement(%s)",$str) 103 | } 104 | return $str; 105 | } 106 | 107 | 108 | method is_fuzzy() { 109 | return ( %!IS_FUZZY.exists(self.start_pos_type) || 110 | %!IS_FUZZY.exists(self.end_pos_type)) ?? True !! False; 111 | } 112 | 113 | method length() { 114 | given (self.location_type) { 115 | when 'EXACT' { 116 | return self.end - self.start + 1; 117 | } 118 | when 'WITHIN' { 119 | return self.end - self.start + 1; 120 | } 121 | default { 122 | return 0 123 | } 124 | } 125 | } 126 | 127 | 128 | 129 | method valid_Location() { 130 | return defined($.start) && defined($.end) ?? True !! False; 131 | } 132 | 133 | 134 | method to_FTstring() { 135 | my $str; 136 | if ( self.start == self.end ) { 137 | $str = self.start; 138 | } else { 139 | $str = self.start ~ %RANGEDECODE{self.location_type} ~ self.end; 140 | } 141 | if (self.is_remote() && self.seq_id()) { 142 | $str = self.seq_id() ~ ':' ~ $str; 143 | } 144 | if ( defined self.strand && 145 | self.strand == -1 ) { 146 | $str = 'complement(' ~ $str ~ ')'; 147 | } 148 | return $str; 149 | } 150 | 151 | 152 | multi method min_start() { 153 | my $start = self.start; 154 | return if !$start || (self.start_pos_type eq 'BEFORE'); 155 | return $start; 156 | } 157 | 158 | multi method max_start() { 159 | my $start = self.start; 160 | return unless $start; 161 | ($start + self.start_offset); 162 | } 163 | 164 | multi method max_end() { 165 | my $end = self.end; 166 | return if !$end || (self.end_pos_type eq 'AFTER'); 167 | return ($end + self.end_offset); 168 | } 169 | 170 | multi method min_end() { 171 | return self.end; 172 | } 173 | 174 | 175 | 176 | } 177 | -------------------------------------------------------------------------------- /nyi/Bio/Role/Location/Split.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Bio::Role::Location; 3 | 4 | role Bio::Role::Location::Split does Bio::Role::Location { 5 | 6 | has @!subLocations; 7 | has $.splittype is rw = 'JOIN'; 8 | 9 | method add_sub_Location(*@locations){ 10 | for @locations -> $loc { 11 | #in time this will need to be reviewed and fix. Need a common interface 12 | if ($loc !~~ Bio::Role::Location && $loc !~~ Bio::SeqFeature::Lite) { 13 | #old bioperl5 msg 14 | #self.throw("Trying to add $loc as a sub Location but it doesn't implement Bio::LocationI!"); 15 | next; 16 | } 17 | push @!subLocations,$loc; 18 | } 19 | return @!subLocations.elems; 20 | } 21 | 22 | multi method each_Location(Int $order = 0){ 23 | my @locs; 24 | for self.sub_Location($order) -> $subloc { 25 | # Recursively check to get hierarchical split locations: 26 | push @locs, $subloc.each_Location($order); 27 | } 28 | return @locs; 29 | } 30 | 31 | method sub_Location(Int $order = 0) { 32 | #not sure if we really need... 33 | $order = 1 if ($order > 1); 34 | $order = -1 if ($order < -1); 35 | #### 36 | 37 | my @sublocs = defined @!subLocations ?? @!subLocations !! (); 38 | 39 | 40 | # return the array if no ordering requested 41 | return @sublocs if ( ($order == 0) || !(defined @sublocs) ); 42 | 43 | # sort those locations that are on the same sequence as the top (`master') 44 | # if the top seq is undefined, we take the first defined in a sublocation 45 | my $seqid = self.seq_id(); 46 | my $i = 0; 47 | while ((! defined($seqid)) && ($i <= @sublocs.end)) { 48 | $seqid = @sublocs[$i++].seq_id(); 49 | } 50 | 51 | if ((! self.seq_id()) && defined($seqid)) { 52 | #probably want to keep this 53 | # $self->warn("sorted sublocation array requested but ". 54 | # "root location doesn't define seq_id ". 55 | # "(at least one sublocation does!)"); 56 | } 57 | 58 | my @locs = ($seqid ?? 59 | grep { $_.seq_id() eq $seqid; } , @sublocs !! 60 | @sublocs); 61 | 62 | 63 | 64 | if (@locs) { 65 | if ($order == 1) { 66 | # Schwartzian transforms for performance boost 67 | @locs = map { $_.[0] } , 68 | sort { 69 | (defined $^a && defined $^b) ?? $^a.[1] <=> $^b.[1] !! 70 | $^a ?? -1 !! 1 71 | } , map { [$_, (defined $_.start ?? $_.start !! $_.end)] } , @locs; 72 | } else { # $order == -1 73 | 74 | @locs = map { $_.[0] } , 75 | sort { 76 | (defined $^a && defined $^b) ?? $^b.[1] <=> $^a.[1] !! 77 | $^a ?? -1 !! 1 78 | } , map { [$_, (defined $_.end ?? $_.end !! $_.start)] } ,@locs; 79 | } 80 | } 81 | 82 | # push the rest unsorted 83 | if ($seqid) { 84 | push(@locs, grep { $_.seq_id() ne $seqid; } ,@sublocs); 85 | } 86 | # done! 87 | 88 | return @locs; 89 | } 90 | 91 | 92 | method to_FTstring(){ 93 | my @strs; 94 | my $strand = self.strand() || 0; 95 | my $stype = lc(self.splittype()); 96 | my $guide = self.guide_strand(); 97 | 98 | if ( $strand < 0 ) { 99 | self.flip_strand; # this will recursively set the strand 100 | # to +1 for all the sub locations 101 | } 102 | 103 | # If the split type is join, the order is important; 104 | # otherwise must be 5'->3' regardless 105 | 106 | my @locs = ($stype eq 'join' && (!$guide && $strand == -1)) ?? 107 | reverse self.sub_Location() !! self.sub_Location() ; 108 | 109 | for ( @locs ) -> $loc { 110 | # $loc.verbose(self.verbose); 111 | my $str = $loc.to_FTstring(); 112 | # we only append the remote seq_id if it hasn't been done already 113 | # by the sub-location (which it should if it knows it's remote) 114 | # (and of course only if it's necessary) 115 | if ( (! $loc.is_remote) && 116 | defined(self.seq_id) && defined($loc.seq_id) && 117 | ($loc.seq_id ne self.seq_id) ) { 118 | $str = sprintf("%s:%s", $loc.seq_id, $str); 119 | } 120 | push @strs, $str; 121 | } 122 | self.flip_strand if $strand < 0; 123 | my $str; 124 | if ( @strs == 1 ) { 125 | ($str) = @strs; 126 | } elsif ( @strs == 0 ) { 127 | # self.warn("no Sublocations for this splitloc, so not returning anything\n"); 128 | } else { 129 | $str = sprintf('%s(%s)',lc(self.splittype), join(",", @strs)); 130 | } 131 | if ( $strand < 0 ) { # wrap this in a complement if it was unrolled 132 | $str = sprintf('%s(%s)','complement',$str); 133 | } 134 | 135 | return $str; 136 | } 137 | 138 | #bioperl5 version had these values return by coord policy but that is over design 139 | #going to need a faster way to determine start other then resorting every time 140 | multi method start(){ 141 | my @locs = self.sub_Location(1); 142 | return @locs[0].min_start() if @locs; 143 | return; 144 | } 145 | 146 | multi method end(){ 147 | # reverse sort locations by largest ending to smallest ending 148 | my @locs = self.sub_Location(-1); 149 | return @locs[0].max_end() if @locs; 150 | return; 151 | } 152 | ### 153 | 154 | 155 | method min_start() { 156 | my @locs = self.sub_Location(1); 157 | return @locs[0].min_start() if @locs; 158 | return; 159 | } 160 | 161 | method max_start() { 162 | my @locs = self.sub_Location(1); 163 | return @locs[0].max_start() if @locs; 164 | return; 165 | } 166 | 167 | method max_end() { 168 | # reverse sort locations by largest ending to smallest ending 169 | my @locs = self.sub_Location(-1); 170 | return @locs[0].max_end() if @locs; 171 | return; 172 | } 173 | 174 | method min_end() { 175 | # reverse sort locations by largest ending to smallest ending 176 | my @locs = self.sub_Location(-1); 177 | return @locs[0].min_end() if @locs; 178 | return; 179 | } 180 | 181 | multi method flip_strand() { 182 | for ( self.sub_Location(0) ) -> $loc { 183 | $loc.flip_strand(); 184 | if ($loc ~~ Bio::Role::Location::Split) { 185 | my $gs = (self.guide_strand == -1) ?? Mu !! -1; 186 | $loc.guide_strand($gs); 187 | } 188 | } 189 | } 190 | 191 | method guide_strand($value?) { 192 | return self.strand = $value if defined($value); 193 | return self.strand; 194 | } 195 | 196 | 197 | multi method strand($value?) { 198 | if ( defined $value) { 199 | self.strand = $value; 200 | # propagate to all sublocs 201 | for (self.sub_Location(0)) -> $loc { 202 | $loc.strand($value); 203 | } 204 | } 205 | else { 206 | my ($strand, $lstrand); 207 | for (self.sub_Location(0)) -> $loc { 208 | # we give up upon any location that's remote or doesn't have 209 | # the strand specified, or has a differing one set than 210 | # previously seen. 211 | # calling strand() is potentially expensive if the subloc is also 212 | # a split location, so we cache it 213 | $lstrand = $loc.strand(); 214 | if ((! $lstrand) || 215 | ($strand && ($strand != $lstrand)) || 216 | $loc.is_remote()) { 217 | $strand = Any; 218 | last; 219 | } elsif (! $strand) { 220 | $strand = $lstrand; 221 | } 222 | } 223 | return $strand; 224 | } 225 | 226 | } 227 | 228 | 229 | 230 | } 231 | -------------------------------------------------------------------------------- /nyi/Bio/Role/RichSeq.pm6: -------------------------------------------------------------------------------- 1 | role Bio::Role::RichSeq { 2 | # wondering if this should be simplified (see comments) and merged with 3 | # Bio::Role::Seq... 4 | 5 | has Str $.division is rw; 6 | has Str $.molecule is rw; # this is pretty close to moltype, which is deprecated... 7 | 8 | # the next two may be removed based on input 9 | has Str $.pid is rw; # is this the same as .primary_id? (Bio::Role::Identify) 10 | has Str $.seq_version is rw; # is this the same as .version? (Bio::Role::Identify) 11 | 12 | # These grab the (stringified) data from the annotation collection using the 13 | # corresponding type (the tag name). They're really convenience methods for 14 | # add_Annotation('foo', @foo) and get_Annotations('foo'), so we can probably 15 | # decide whether or not it's necessary to even have a RichSeq role as anything 16 | # more than a convenience 17 | 18 | # TODO: typed arrays/hashes are not implemented in rakudo 19 | 20 | our Bool method add_secondary_accessions ( 21 | Str :$type = 'secondary_accession', Str *@accession 22 | ) 23 | {...} 24 | our Array of Str method get_secondary_accessions ( 25 | Str :$type = 'secondary_accession' 26 | ) 27 | {...} 28 | 29 | our Bool method add_dates ( 30 | Str :$type = 'date_changed', Str *@dates 31 | ) 32 | {...} 33 | our Array of Str method get_dates ( 34 | Str :$type = 'date_changed', Str :$date 35 | ) 36 | {...} 37 | 38 | our Bool method add_keywords ( 39 | Str :$type = 'keyword', *@keywords, 40 | ) 41 | {...} 42 | our Array of Str method get_keywords ( 43 | Str :$type = 'keyword', Str :$keyword 44 | ) 45 | {...} 46 | } 47 | -------------------------------------------------------------------------------- /nyi/Bio/SeqIO.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | class Bio::SeqIO { 4 | 5 | has $!format; 6 | 7 | method new(Str $format, $file,:$write?){ 8 | my Junction $formats = any ('fasta'|'genbank'); 9 | 10 | my $obj; 11 | 12 | #could maybe use a junction in the future but simple for now 13 | if lc($format) eq 'fasta' { 14 | use Bio::Role::FastaIO; 15 | $obj = self.bless(*,:$format) does Bio::Role::FastaIO[$file]; 16 | 17 | #should not have to do this...... 18 | if $write { 19 | $obj.initial_write(); 20 | } 21 | else { 22 | $obj!set_io(True,separator => '>'); 23 | } 24 | } 25 | else { 26 | #need to use Bio::Root::Root 27 | say ("Cannot accept $format yet"); 28 | } 29 | 30 | return $obj; 31 | } 32 | 33 | 34 | } 35 | -------------------------------------------------------------------------------- /nyi/t/Factory/FTLocationFactory.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use Test; 4 | plan 268; 5 | eval_lives_ok 'use Bio::Factory::FTLocationFactory', 'Can use Bio::Factory::FTLocationFactory'; 6 | 7 | 8 | 9 | use Bio::Factory::FTLocationFactory; 10 | 11 | 12 | my $simple_impl = Bio::Role::Location::Simple; 13 | my $fuzzy_impl = Bio::Role::Location::Fuzzy; 14 | my $split_impl = Bio::Role::Location::Split; 15 | 16 | # Holds strings and results. The latter is an array of expected class name, 17 | # min/max start position and position type, min/max end position and position 18 | # type, location type, the number of locations, and the strand. 19 | # 20 | my %testcases = ( 21 | # note: the following are directly taken from 22 | # http://www.ncbi.nlm.nih.gov/collab/FT/#location 23 | "467" => [$simple_impl, 24 | 467, 467, "EXACT", 467, 467, "EXACT", "EXACT", 1, 1], 25 | "340..565" => [$simple_impl, 26 | 340, 340, "EXACT", 565, 565, "EXACT", "EXACT", 1, 1], 27 | "<345..500" => [$fuzzy_impl, 28 | Any, 345, "BEFORE", 500, 500, "EXACT", "EXACT", 1, 1], 29 | "<1..888" => [$fuzzy_impl, 30 | Any, 1, "BEFORE", 888, 888, "EXACT", "EXACT", 1, 1], 31 | "(102.110)" => [$fuzzy_impl, 32 | 102, 102, "EXACT", 110, 110, "EXACT", "WITHIN", 1, 1], 33 | "(23.45)..600" => [$fuzzy_impl, 34 | 23, 45, "WITHIN", 600, 600, "EXACT", "EXACT", 1, 1], 35 | "(122.133)..(204.221)" => [$fuzzy_impl, 36 | 122, 133, "WITHIN", 204, 221, "WITHIN", "EXACT", 1, 1], 37 | "123^124" => [$simple_impl, 38 | 123, 123, "EXACT", 124, 124, "EXACT", "IN-BETWEEN", 1, 1], 39 | "145^177" => [$fuzzy_impl, 40 | 145, 145, "EXACT", 177, 177, "EXACT", "IN-BETWEEN", 1, 1], 41 | "join(12..78,134..202)" => [$split_impl, 42 | 12, 12, "EXACT", 202, 202, "EXACT", "EXACT", 2, 1], 43 | "complement(join(4918..5163,2691..4571))" => [$split_impl, 44 | 2691, 2691, "EXACT", 5163, 5163, "EXACT", "EXACT", 2, -1], 45 | "complement(34..(122.126))" => [$fuzzy_impl, 46 | 34, 34, "EXACT", 122, 126, "WITHIN", "EXACT", 1, -1], 47 | "J00194:100..202" => [$simple_impl, 48 | 100, 100, "EXACT", 202, 202, "EXACT", "EXACT", 1, 1], 49 | # this variant is not really allowed by the FT definition 50 | # document but we want to be able to cope with it 51 | "J00194:(100..202)" => [$simple_impl, 52 | 100, 100, "EXACT", 202, 202, "EXACT", "EXACT", 1, 1], 53 | "((122.133)..(204.221))" => [$fuzzy_impl, 54 | 122, 133, "WITHIN", 204, 221, "WITHIN", "EXACT", 1, 1], 55 | "join(AY016290.1:108..185,AY016291.1:1546..1599)"=> [$split_impl, 56 | 108, 108, "EXACT", 185, 185, "EXACT", "EXACT", 2, Any], 57 | 58 | # UNCERTAIN locations and positions (Swissprot) 59 | "?2465..2774" => [$fuzzy_impl, 60 | 2465, 2465, "UNCERTAIN", 2774, 2774, "EXACT", "EXACT", 1, 1], 61 | "22..?64" => [$fuzzy_impl, 62 | 22, 22, "EXACT", 64, 64, "UNCERTAIN", "EXACT", 1, 1], 63 | "?22..?64" => [$fuzzy_impl, 64 | 22, 22, "UNCERTAIN", 64, 64, "UNCERTAIN", "EXACT", 1, 1], 65 | "?..>393" => [$fuzzy_impl, 66 | Any, Any, "UNCERTAIN", 393, Any, "AFTER", "UNCERTAIN", 1, 1], 67 | "<1..?" => [$fuzzy_impl, 68 | Any, 1, "BEFORE", Any, Any, "UNCERTAIN", "UNCERTAIN", 1, 1], 69 | "?..536" => [$fuzzy_impl, 70 | Any, Any, "UNCERTAIN", 536, 536, "EXACT", "UNCERTAIN", 1, 1], 71 | "1..?" => [$fuzzy_impl, 72 | 1, 1, "EXACT", Any, Any, "UNCERTAIN", "UNCERTAIN", 1, 1], 73 | "?..?" => [$fuzzy_impl, 74 | Any, Any, "UNCERTAIN", Any, Any, "UNCERTAIN", "UNCERTAIN", 1, 1], 75 | # Not working yet: 76 | # not sure if this should be valided - takadonet 77 | #"12..?1" => [$fuzzy_impl, 78 | # 1, 1, "UNCERTAIN", 12, 12, "EXACT", "EXACT", 1, 1] 79 | ); 80 | 81 | my $locfac = Bio::Factory::FTLocationFactory.new(); 82 | ok($locfac ~~ Bio::Factory::FTLocationFactory, 'Is Bio::Location::FTLocationFactory Role'); 83 | 84 | # sorting is to keep the order constant from one run to the next 85 | for keys %testcases -> $locstr is copy { 86 | my $loc = $locfac.from_string($locstr); 87 | if ($locstr eq "join(AY016290.1:108..185,AY016291.1:1546..1599)") { 88 | $loc.seq_id ="AY016295.1"; 89 | } 90 | my @res = @(%testcases{$locstr}); 91 | is($loc.WHAT, @res[0], @res[0]); 92 | is($loc.min_start(), @res[1]); 93 | is($loc.max_start(), @res[2]); 94 | is($loc.start_pos_type(), @res[3]); 95 | is($loc.min_end(), @res[4]); 96 | is($loc.max_end(), @res[5]); 97 | is($loc.end_pos_type(), @res[6]); 98 | is($loc.location_type(), @res[7]); 99 | my @locs = $loc.each_Location(); 100 | is(@locs.elems, @res[8]); 101 | my $ftstr = $loc.to_FTstring(); 102 | # this is a somewhat ugly hack, but we want clean output from to_FTstring() 103 | # Umm, then these should really fail, correct? 104 | # Should we be engineering workarounds for tests? 105 | $locstr = "J00194:100..202" if $locstr eq "J00194:(100..202)"; 106 | $locstr = "(122.133)..(204.221)" if $locstr eq "((122.133)..(204.221))"; 107 | # now test 108 | is($ftstr, $locstr, "Location String: $locstr"); 109 | # test strand production 110 | is($loc.strand(), @res[9]); 111 | 112 | } 113 | 114 | # bug #1674, #1765, 2101 115 | # EMBL-like 116 | # join(20464..20694,21548..22763,join(complement(314652..314672),complement(232596..232990),complement(231520..231669))) 117 | # GenBank-like 118 | # join(20464..20694,21548..22763,complement(join(231520..231669,232596..232990,314652..314672))) 119 | # Note that 120 | # join(1000..2000,join(3000..4000,join(5000..6000,7000..8000)),9000..10000) 121 | # is the same as 122 | # join(1000..2000,3000..4000,5000..6000,7000..8000,9000..10000) 123 | # But I don't want to bother with it at this point 124 | my @expected = (# intentionally testing same expected string twice 125 | # as I am providing two different encodings 126 | # that should mean the same thing 127 | # 'join(11025..11049,complement(join(315036..315294,251354..251412,241499..241580,239890..240081)))', 128 | 'join(11025..11049,complement(join(315036..315294,251354..251412,241499..241580,239890..240081)))', 129 | # ditto 130 | 'join(20464..20694,21548..22763,complement(join(314652..314672,232596..232990,231520..231669)))', 131 | # 'join(20464..20694,21548..22763,complement(join(314652..314672,232596..232990,231520..231669)))', 132 | # this is just seen once 133 | # 'join(1000..2000,join(3000..4000,join(5000..6000,7000..8000)),9000..10000)' 134 | ); 135 | 136 | for ( 137 | # 'join(11025..11049,join(complement(239890..240081),complement(241499..241580),complement(251354..251412),complement(315036..315294)))', 138 | 'join(11025..11049,complement(join(315036..315294,251354..251412,241499..241580,239890..240081)))', 139 | 'join(20464..20694,21548..22763,complement(join(314652..314672,232596..232990,231520..231669)))', 140 | # 'join(20464..20694,21548..22763,join(complement(231520..231669),complement(232596..232990),complement(314652..314672)))', 141 | # 'join(1000..2000,join(3000..4000,join(5000..6000,7000..8000)),9000..10000)' 142 | ) -> $locstr { 143 | my $loc = $locfac.from_string($locstr); 144 | my $ftstr = $loc.to_FTstring(); 145 | is($ftstr, (@expected.shift), $locstr); 146 | } 147 | -------------------------------------------------------------------------------- /nyi/t/LiveSeq/Mutation.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use Test; 4 | plan 44; 5 | eval_lives_ok 'use Bio::LiveSeq::Mutation', 'Can use Bio::LiveSeq::Mutation'; 6 | 7 | use Bio::LiveSeq::Mutation; 8 | 9 | 10 | my $a = Bio::LiveSeq::Mutation.new(); 11 | ok defined $a; 12 | 13 | $a.seq('aaa'); 14 | is $a.seq, 'aaa'; 15 | 16 | $a.seqori('ggg'); 17 | is $a.seqori, 'ggg'; 18 | 19 | $a.pos(-4); 20 | is $a.pos, -4; 21 | 22 | $a.pos(5); 23 | is $a.pos, 5; 24 | 25 | is($a.len, 3); 26 | 27 | $a.len(9); 28 | is($a.len, 9); 29 | 30 | $a.transpos(55); 31 | is $a.transpos, 55; 32 | 33 | $a.issue(1); 34 | is $a.issue, 1; 35 | 36 | $a.label(57); 37 | is $a.label, '57'; 38 | 39 | $a.prelabel(57); 40 | is $a.prelabel, '57'; 41 | 42 | $a.postlabel(57); 43 | is $a.postlabel, '57'; 44 | 45 | $a.lastlabel(57); 46 | is $a.lastlabel, '57'; 47 | 48 | #constuctor test 49 | my $b = Bio::LiveSeq::Mutation.new(seq=>'AC', 50 | seqori => 'GG', 51 | pos => 5, 52 | len => 2, 53 | ); 54 | ok defined $b; 55 | is $b.seqori, 'GG'; 56 | is $b.len, 2; 57 | is $b.seq, 'AC'; 58 | is $b.pos, 5; 59 | 60 | 61 | 62 | 63 | # full descrition of a point mutation 64 | my $mutation1a = Bio::LiveSeq::Mutation.new( seq => 'A', 65 | seqori => 'T', 66 | pos => 100, 67 | len => 1 # optional, defaults to length(seq) 68 | ); 69 | ok defined $mutation1a; 70 | is $mutation1a.seqori, 'T'; 71 | is $mutation1a.len, 1; 72 | is $mutation1a.seq, 'A'; 73 | is $mutation1a.pos, 100; 74 | 75 | # minimal information for a point mutation 76 | my $mutation1b = Bio::LiveSeq::Mutation.new( seq => 'A', 77 | pos => 100 78 | ); 79 | ok defined $mutation1b; 80 | is $mutation1b.seqori, ''; 81 | is $mutation1b.len, 1; 82 | is $mutation1b.seq, 'A'; 83 | is $mutation1b.pos, 100; 84 | 85 | # insertion 86 | my $mutation2 = Bio::LiveSeq::Mutation.new( seq => 'ATT', 87 | pos => 100, 88 | len => 0 89 | ); 90 | ok defined $mutation2; 91 | is $mutation2.seqori, ''; 92 | is $mutation2.len, 3; 93 | is $mutation2.seq, 'ATT'; 94 | is $mutation2.pos, 100; 95 | 96 | # deletion 97 | my $mutation3 = Bio::LiveSeq::Mutation.new( seq => '', # optional 98 | seqori => 'TTG', # optional 99 | pos => 100, 100 | len => 3 101 | ); 102 | ok defined $mutation3; 103 | is $mutation3.seqori, 'TTG'; 104 | is $mutation3.len, 3; 105 | is $mutation3.seq, ''; 106 | is $mutation3.pos, 100; 107 | 108 | 109 | # complex 110 | my $mutation4 = Bio::LiveSeq::Mutation.new( seq => 'CC', 111 | seqori => 'TTG', # optional 112 | pos => 100, 113 | len => 3 114 | ); 115 | ok defined $mutation4; 116 | is $mutation4.seqori, 'TTG'; 117 | is $mutation4.len, 3; 118 | is $mutation4.seq, 'CC'; 119 | is $mutation4.pos, 100; 120 | -------------------------------------------------------------------------------- /nyi/t/Location.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib 'lib'; 4 | 5 | use Test; 6 | #plan 103; 7 | plan 57; 8 | eval_lives_ok 'use Bio::Role::Location::Simple', 'Can use Bio::Role::Location::Simple'; 9 | eval_lives_ok 'use Bio::Role::Location::Split', 'Can use Bio::Role::Location::Split'; 10 | eval_lives_ok 'use Bio::Role::Location::Fuzzy', 'Can use Bio::Role::Location::Fuzzy'; 11 | 12 | use Bio::Tools::IUPAC; 13 | use Bio::PrimarySeq; 14 | 15 | use Bio::Role::Location::Simple; 16 | use Bio::Role::Location::Split; 17 | use Bio::Role::Location::Fuzzy; 18 | 19 | #use Bio::SeqFeature::Generic; 20 | #use Bio::SeqFeature::SimilarityPair; 21 | #use Bio::SeqFeature::FeaturePair; 22 | 23 | 24 | my $simple = Bio::Role::Location::Simple.new(start => 10, end => 20, 25 | strand => 1, seq_id => 'my1'); 26 | # isa_ok($simple, 'Bio::LocationI'); 27 | # isa_ok($simple, 'Bio::RangeI'); 28 | 29 | is($simple.start, 10, 'Bio::Role::Location::Simple tests'); 30 | is($simple.end, 20); 31 | is($simple.seq_id, 'my1'); 32 | 33 | my ($loc) = $simple.each_Location(); 34 | ok($loc); 35 | is($loc, $simple); 36 | 37 | # my $generic = Bio::SeqFeature::Generic.new(start => 5, end => 30, 38 | # strand => 1); 39 | 40 | # isa_ok($generic,'Bio::SeqFeatureI', 'Bio::SeqFeature::Generic' ); 41 | # isa_ok($generic,'Bio::RangeI'); 42 | # is($generic.start, 5); 43 | # is($generic.end, 30); 44 | 45 | # my $similarity = Bio::SeqFeature::SimilarityPair.new(); 46 | 47 | # my $feat1 = Bio::SeqFeature::Generic.new(start => 30, end => 43, 48 | # strand => -1); 49 | # my $feat2 = Bio::SeqFeature::Generic.new(start => 80, end => 90, 50 | # strand => -1); 51 | 52 | # my $featpair = Bio::SeqFeature::FeaturePair.new(feature1 => $feat1, 53 | # feature2 => $feat2 ); 54 | 55 | # my $feat3 = Bio::SeqFeature::Generic.new(start => 35, end => 50, 56 | # strand => -1); 57 | 58 | # is($featpair.start, 30,'Bio::SeqFeature::FeaturePair tests'); 59 | # is($featpair.end, 43); 60 | 61 | # is($featpair.length, 14); 62 | 63 | # ok($featpair.overlaps($feat3)); 64 | # ok($generic.overlaps($simple), 'Bio::SeqFeature::Generic tests'); 65 | # ok($generic.contains($simple)); 66 | 67 | # # fuzzy location tests 68 | my $fuzzy = Bio::Role::Location::Fuzzy.new(start =>'<10', 69 | end => 20, 70 | strand =>1, 71 | seq_id =>'my2'); 72 | 73 | is($fuzzy.strand, 1, 'Bio::Role::Location::Fuzzy tests'); 74 | is($fuzzy.start, 10); 75 | is($fuzzy.end,20); 76 | ok(!defined $fuzzy.min_start); 77 | is($fuzzy.max_start, 10); 78 | is($fuzzy.min_end, 20, 'min_end'); 79 | is($fuzzy.max_end, 20, 'max_end'); 80 | is($fuzzy.location_type, 'EXACT'); 81 | is($fuzzy.start_pos_type, 'BEFORE'); 82 | is($fuzzy.end_pos_type, 'EXACT'); 83 | is($fuzzy.seq_id, 'my2'); 84 | is(($fuzzy.seq_id ='my3'), 'my3'); 85 | 86 | ($loc) = $fuzzy.each_Location(); 87 | ok($loc); 88 | is($loc, $fuzzy); 89 | 90 | # split location tests 91 | my $splitlocation = Bio::Role::Location::Split.new(); 92 | my $f = Bio::Role::Location::Simple.new(start => 13, 93 | end => 30, 94 | strand => 1); 95 | $splitlocation.add_sub_Location($f); 96 | is($f.start, 13, 'Bio::Role::Location::Split tests'); 97 | is($f.min_start, 13); 98 | is($f.max_start,13); 99 | 100 | 101 | $f = Bio::Role::Location::Simple.new(start =>30, 102 | end =>90, 103 | strand =>1); 104 | $splitlocation.add_sub_Location($f); 105 | 106 | $f = Bio::Role::Location::Simple.new(start =>18, 107 | end =>22, 108 | strand =>1); 109 | $splitlocation.add_sub_Location($f); 110 | 111 | $f = Bio::Role::Location::Simple.new(start =>19, 112 | end =>20, 113 | strand =>1); 114 | 115 | $splitlocation.add_sub_Location($f); 116 | 117 | $f = Bio::Role::Location::Fuzzy.new(start =>"<50", 118 | end =>61, 119 | strand =>1); 120 | is($f.start, 50); 121 | ok(! defined $f.min_start); 122 | is($f.max_start, 50); 123 | 124 | is($splitlocation.each_Location().elems(), 4, 'Number of locations'); 125 | 126 | $splitlocation.add_sub_Location($f); 127 | 128 | is($splitlocation.max_end, 90); 129 | is($splitlocation.min_start, 13); 130 | is($splitlocation.end, 90); 131 | is($splitlocation.start, 13,'start'); 132 | is($splitlocation.sub_Location().elems,5); 133 | 134 | 135 | is($fuzzy.to_FTstring(), '<10..20'); 136 | $fuzzy.strand(-1); 137 | is($fuzzy.to_FTstring(), 'complement(<10..20)'); 138 | is($simple.to_FTstring(), '10..20'); 139 | $simple.strand(-1); 140 | is($simple.to_FTstring(), 'complement(10..20)'); 141 | is( $splitlocation.to_FTstring(), 142 | 'join(13..30,30..90,18..22,19..20,<50..61)'); 143 | 144 | # test for bug #1074 145 | $f = Bio::Role::Location::Simple.new(start => 5, 146 | end => 12, 147 | strand => -1); 148 | $splitlocation.add_sub_Location($f); 149 | is( $splitlocation.to_FTstring(), 150 | 'join(13..30,30..90,18..22,19..20,<50..61,complement(5..12))', 151 | 'Bugfix 1074'); 152 | $splitlocation.strand(-1); 153 | is( $splitlocation.to_FTstring(), 154 | 'complement(join(13..30,30..90,18..22,19..20,<50..61,5..12))'); 155 | 156 | $f = Bio::Role::Location::Fuzzy.new(start => '45.60', 157 | end => '75^80'); 158 | 159 | is($f.to_FTstring(), '(45.60)..(75^80)'); 160 | $f.start('20>'); 161 | is($f.to_FTstring(), '>20..(75^80)'); 162 | 163 | # test that even when end < start that length is always positive 164 | 165 | $f = Bio::Role::Location::Simple.new(verbose => -1, 166 | start => 100, 167 | end => 20, 168 | strand => 1); 169 | # need help, are we doing verbose? 170 | # is($f.length, 81, 'Positive length'); 171 | # is($f.strand,-1); 172 | 173 | # test that can call seq_id() on a split location; 174 | $splitlocation = Bio::Role::Location::Split.new(seq_id => 'mysplit1'); 175 | is( $splitlocation.seq_id ,'mysplit1', 'seq_id() on Bio::Role::Location::Split'); 176 | is(($splitlocation.seq_id ='mysplit2'),'mysplit2'); 177 | 178 | 179 | # Test Bio::Location::Exact 180 | 181 | ok(my $exact = Bio::Role::Location::Simple.new(start => 10, 182 | end => 20, 183 | strand => 1, 184 | seq_id => 'my1')); 185 | # isa_ok($exact, 'Bio::LocationI'); 186 | # isa_ok($exact, 'Bio::RangeI'); 187 | 188 | is( $exact.start, 10, 'Bio::Role::Location::Simple EXACT'); 189 | is( $exact.end, 20); 190 | is( $exact.seq_id, 'my1'); 191 | is( $exact.length, 11); 192 | is( $exact.location_type, 'EXACT'); 193 | 194 | ok ($exact = Bio::Role::Location::Simple.new(start => 10, 195 | end => 11, 196 | location_type => 'IN-BETWEEN', 197 | strand => 1, 198 | seq_id => 'my2')); 199 | 200 | is($exact.start, 10, 'Bio::Role::Location::Simple IN-BETWEEN'); 201 | is($exact.end, 11); 202 | is($exact.seq_id, 'my2'); 203 | is($exact.length, 0); 204 | is($exact.location_type, 'IN-BETWEEN'); 205 | 206 | # eval { 207 | # $exact = Bio::Role::Location::Simple.new(start => 10, 208 | # end => 12, 209 | # location_type => 'IN-BETWEEN'); 210 | # }; 211 | # ok( $@, 'Testing error handling' ); 212 | 213 | # # testing error when assigning 10^11 simple location into fuzzy 214 | # eval { 215 | # ok $fuzzy = Bio::Role::Location::Fuzzy.new(start => 10, 216 | # end => 11, 217 | # location_type => '^', 218 | # strand => 1, 219 | # seq_id => 'my2'); 220 | # }; 221 | # ok( $@ ); 222 | 223 | # $fuzzy = Bio::Role::Location::Fuzzy.new(location_type => '^', 224 | # strand => 1, 225 | # seq_id => 'my2'); 226 | 227 | # $fuzzy.start(10); 228 | # eval { $fuzzy.end(11) }; 229 | # ok($@); 230 | 231 | # $fuzzy = Bio::Role::Location::Fuzzy.new(location_type => '^', 232 | # strand => 1, 233 | # seq_id =>'my2'); 234 | 235 | # $fuzzy.end(11); 236 | # eval { 237 | # $fuzzy.start(10); 238 | # }; 239 | # ok($@); 240 | 241 | -------------------------------------------------------------------------------- /nyi/t/Location/Simple.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use Test; 4 | plan 70; 5 | eval_lives_ok 'use Bio::Role::Location::Simple', 'Can use Bio::Role::Location::Simple'; 6 | use Bio::Role::Location::Simple; 7 | 8 | my $simple = Bio::Role::Location::Simple.new( 9 | start => 10, 10 | end => 20, 11 | strand => 1, 12 | seq_id => 'my1', 13 | is_remote => 1); 14 | ok($simple ~~ Bio::Role::Location::Simple, 'Has Bio::Role::Location::Simple Role'); 15 | ok($simple ~~ Bio::Role::Location, 'Has Bio::Role::Location Role'); 16 | 17 | # does_ok($simple, 'Biome::Role::Location::Does_Range', 'has basic Range interface'); 18 | # does_ok($simple, 'Biome::Role::Location::Does_Location', 'has more defined Location interface'); 19 | 20 | is($simple.start, 10, 'has a start location'); 21 | is($simple.end, 20, 'has an end location'); 22 | is($simple.seq_id, 'my1', 'has an identifier'); 23 | is($simple.start_pos_type, 'EXACT', 'pos_type is EXACT for start'); 24 | is($simple.end_pos_type, 'EXACT', 'pos_type is EXACT for end'); 25 | ok($simple.valid_Location); 26 | is($simple.location_type, 'EXACT', 'has a default location type'); 27 | ok(!$simple.is_fuzzy); 28 | 29 | is($simple.to_string, 'my1:10..20', 'full FT string'); 30 | 31 | # test that even when end < start that length is always positive 32 | # conflicted. Above statement is the complete opposite of what the tests below are testing for. Commenting it out for now. 33 | # my $f = Bio::Role::Location::Simple.new( 34 | # strict => -1, 35 | # start => 100, 36 | # end => 20, 37 | # strand => 1); 38 | 39 | # is($f.length(), 81, 'Positive length'); 40 | # is($f.strand(),-1, 'Negative strand' ); 41 | 42 | # is($f.to_string, 'complement(20..100)','full FT string'); 43 | ########## 44 | 45 | my $exact = Bio::Role::Location::Simple.new( 46 | start => 10, 47 | end => 11, 48 | location_type => 'IN-BETWEEN', 49 | strand => 1, 50 | seq_id => 'my2'); 51 | 52 | is($exact.start, 10, 'Bio::Roleme::Location::Simple IN-BETWEEN'); 53 | is($exact.end, 11); 54 | is($exact.seq_id, 'my2'); 55 | is($exact.length, 0); 56 | is($exact.location_type, 'IN-BETWEEN'); 57 | ok(!$exact.is_fuzzy); 58 | 59 | is($exact.to_string, '10^11','full FT string'); 60 | 61 | # check coercions with location_type and strand 62 | $exact = Bio::Role::Location::Simple.new( 63 | start => 10, 64 | end => 11, 65 | location_type => '^', 66 | strand => '+'); 67 | 68 | is($exact.start, 10, 'Bio::Role::Location::Simple IN-BETWEEN'); 69 | is($exact.end, 11); 70 | is($exact.strand, 1, 'strand coerced'); 71 | is($exact.seq_id, Any); 72 | is($exact.length, 0); 73 | is($exact.location_type, 'IN-BETWEEN'); 74 | is($exact.start_pos_type, 'EXACT'); 75 | is($exact.end_pos_type, 'EXACT'); 76 | 77 | is($exact.to_string, '10^11', 'full FT string'); 78 | 79 | $exact = Bio::Role::Location::Simple.new( 80 | start => 10, 81 | end => 20, 82 | start_pos_type => '<', 83 | end_pos_type => '>', # this should default to 'EXACT' 84 | strand => '+'); 85 | 86 | is($exact.start, 10); 87 | is($exact.end, 20); 88 | is($exact.strand, 1, 'strand coerced'); 89 | is($exact.seq_id, Any); 90 | is($exact.length, 11); 91 | 92 | # this doesn't seem correct, shouldn't it be 'FUZZY' or 'UNCERTAIN'? 93 | is($exact.location_type, 'EXACT'); 94 | 95 | is($exact.start_pos_type, 'BEFORE'); 96 | is($exact.end_pos_type, 'AFTER'); 97 | ok($exact.is_fuzzy); 98 | 99 | is($exact.to_string, '<10..>20', 'full FT string'); 100 | 101 | # check coercions with start/end_pos_type, and length determination 102 | $exact = Bio::Role::Location::Simple.new( 103 | start => 10, 104 | end => 20, 105 | start_pos_type => '<', 106 | strand => '+'); 107 | 108 | is($exact.start, 10); 109 | is($exact.end, 20); 110 | is($exact.strand, 1, 'strand coerced'); 111 | is($exact.seq_id, Any); 112 | is($exact.length, 11); 113 | is($exact.location_type, 'EXACT'); 114 | is($exact.start_pos_type, 'BEFORE'); 115 | is($exact.end_pos_type, 'EXACT'); 116 | 117 | is($exact.to_string, '<10..20', 'full FT string'); 118 | 119 | # check exception handling 120 | # throws_ok { $exact = $exact = Bio::Role::Location::Simple->new( 121 | # -start => 10, 122 | # -end => 12, 123 | # -start_pos_type => '>', 124 | # -strand => '+') } 125 | # qr/Start position can't have type AFTER/, 126 | # 'Check start_pos_type constraint'; 127 | 128 | # throws_ok { $exact = $exact = Bio::Role::Location::Simple->new( 129 | # -start => 10, 130 | # -end => 12, 131 | # -end_pos_type => '<', 132 | # -strand => '+') } 133 | # qr/End position can't have type BEFORE/, 134 | # 'Check end_pos_type constraint'; 135 | 136 | 137 | # throws_ok {$exact = Bio::Role::Location::Simple->new(-start => 10, 138 | # -end => 12, 139 | # -location_type => 'IN-BETWEEN')} 140 | # qr/length of location with IN-BETWEEN/, 141 | # 'IN-BETWEEN must have length of 1'; 142 | 143 | # fuzzy location tests 144 | my $fuzzy = Bio::Role::Location::Simple.new( 145 | start => 10, 146 | start_pos_type => '<', 147 | end => 20, 148 | strand => 1, 149 | seq_id =>'my2'); 150 | 151 | is($fuzzy.strand, 1, 'Bio::Role::Location::Simple tests'); 152 | is($fuzzy.start, 10); 153 | is($fuzzy.end,20); 154 | ok(!defined $fuzzy.min_start); 155 | is($fuzzy.max_start, 10); 156 | is($fuzzy.min_end, 20); 157 | is($fuzzy.max_end, 20); 158 | is($fuzzy.location_type, 'EXACT'); 159 | is($fuzzy.start_pos_type, 'BEFORE'); 160 | is($fuzzy.end_pos_type, 'EXACT'); 161 | is($fuzzy.seq_id, 'my2'); 162 | #is($fuzzy.seq_id('my3'), 'my3'); 163 | 164 | my $f = Bio::Role::Location::Simple.new( 165 | strict => -1, 166 | start => 100, 167 | end => 20, 168 | strand => 1); 169 | # need help, are we doing verbose? 170 | # is($f.length, 81, 'Positive length'); 171 | # is($f.strand,-1); 172 | 173 | # Test Bio::Role::Location::Simple 174 | 175 | ok($exact = Bio::Role::Location::Simple.new(start => 10, 176 | end => 20, 177 | strand => 1, 178 | seq_id => 'my1')); 179 | #ok($exact ~~ Bio::Role::Role::Location::Does_Range); 180 | 181 | is( $exact.start, 10, 'Bio::Role::Location::Simple EXACT'); 182 | is( $exact.end, 20); 183 | is( $exact.seq_id, 'my1'); 184 | is( $exact.length, 11); 185 | is( $exact.location_type, 'EXACT'); 186 | 187 | ok ($exact = Bio::Role::Location::Simple.new(start => 10, 188 | end => 11, 189 | location_type => 'IN-BETWEEN', 190 | strand => 1, 191 | seq_id => 'my2')); 192 | 193 | is($exact.start, 10, 'Bio::Role::Location::Simple BETWEEN'); 194 | is($exact.end, 11); 195 | is($exact.seq_id, 'my2'); 196 | is($exact.length, 0); 197 | is($exact.location_type, 'IN-BETWEEN'); 198 | 199 | # 'fuzzy' locations are combined with simple ones in Bio::Role 200 | 201 | # my $error = qr/length of location with IN-BETWEEN position type cannot be larger than 1/; 202 | 203 | # # testing error when assigning 10^12 simple location into fuzzy 204 | # throws_ok { 205 | # $fuzzy = Bio::Role::Location::Simple->new( 206 | # -start => 10, 207 | # -end => 12, 208 | # -location_type => '^', 209 | # -strand => 1, 210 | # -seq_id => 'my2'); 211 | # } $error, 'Exception:IN-BETWEEN locations should be contiguous'; 212 | 213 | # $fuzzy = Bio::Role::Location::Simple->new(-location_type => '^', 214 | # -strand => 1, 215 | # -seq_id => 'my2'); 216 | 217 | # $fuzzy->start(10); 218 | # throws_ok { $fuzzy->end(12) } $error, 'Exception:IN-BETWEEN locations should be contiguous'; 219 | 220 | # $fuzzy = Bio::Role::Location::Simple->new(-location_type => '^', 221 | # -strand => 1, 222 | # -seq_id =>'my2'); 223 | 224 | # $fuzzy->end(12); 225 | # throws_ok { $fuzzy->start(10); } $error, 'Exception:IN-BETWEEN locations should be contiguous'; 226 | 227 | 228 | done(); 229 | -------------------------------------------------------------------------------- /nyi/t/SeqFeature/Lite.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | 4 | use Test; 5 | plan 75; 6 | eval_lives_ok 'use Bio::SeqFeature::Lite', 'Can use Bio::SeqFeature::Lite'; 7 | 8 | use Bio::SeqFeature::Lite; 9 | 10 | my $lite = Bio::SeqFeature::Lite.new(); 11 | ok($lite ~~ Bio::SeqFeature::Lite, 'Is Bio::SeqFeature::Lite'); 12 | 13 | $lite = Bio::SeqFeature::Lite.new(start => 1000, 14 | stop => 2000, 15 | type => 'transcript', 16 | name => 'alpha-1 antitrypsin', 17 | desc => 'an enzyme inhibitor', 18 | ); 19 | 20 | is($lite.start,1000,'correct start'); 21 | is($lite.stop,2000,'correct stop'); 22 | is($lite.type,'transcript','Got correct transcript'); 23 | is($lite.desc,'an enzyme inhibitor','Got desc'); 24 | is($lite.display_name,"alpha-1 antitrypsin"); 25 | is($lite.name,'alpha-1 antitrypsin'); 26 | is($lite.seqname,'alpha-1 antitrypsin'); 27 | is($lite.info,'alpha-1 antitrypsin'); 28 | is($lite.display_id,"alpha-1 antitrypsin"); 29 | is($lite.dna,''); 30 | is($lite.start_pos_type,"EXACT"); 31 | is($lite.end_pos_type,"EXACT"); 32 | is($lite.strand,0); 33 | is($lite.class,'Sequence'); 34 | is($lite.feature_count,0); 35 | is($lite.length,1001); 36 | is($lite.location(),$lite,'Should return itself if no segment(s)'); 37 | is($lite.location_string,'1000..2000'); 38 | 39 | 40 | # create a feature composed of multiple segments, all of type "similarity" 41 | my @coord = [1000,1100],[1500,1550],[1800,2000]; 42 | $lite = Bio::SeqFeature::Lite.new(segments => @coord, 43 | name => 'ABC-3', 44 | type => 'gapped_alignment', 45 | subtype => 'similarity'); 46 | 47 | is($lite.start,1000,'correct start'); 48 | is($lite.stop,2000,'correct stop'); 49 | is($lite.end,2000,"correct stop using alias 'end'"); 50 | is($lite.length,1001); 51 | is($lite.type,'gapped_alignment'); 52 | is($lite.desc,Any); 53 | is($lite.display_name,"ABC-3"); 54 | is($lite.name,'ABC-3'); 55 | is($lite.display_id,"ABC-3"); 56 | is($lite.dna,''); 57 | is($lite.start_pos_type,"EXACT"); 58 | is($lite.end_pos_type,"EXACT"); 59 | is($lite.strand,0); 60 | is($lite.class,'Sequence'); 61 | is($lite.type,'gapped_alignment'); 62 | is($lite.feature_count,3); 63 | is($lite.is_circular,False); 64 | is($lite.to_FTstring(),'1000..2000'); 65 | is($lite.location_string,'1000..1100,1500..1550,1800..2000'); 66 | is($lite.score,Any); 67 | 68 | my $split = $lite.location(); 69 | ok($split ~~ Bio::Role::Location::Split,'return Split Object'); 70 | is($split.start,1000,'start from Split'); 71 | is($split.end,2000,'stop from Split'); 72 | 73 | for ($lite.each_Location ) -> $x { 74 | my @feature = @(@coord.shift); 75 | my ($start,$end) = (@feature[0],@feature[1]); 76 | is($x.start,$start); 77 | is($x.end,$end); 78 | } 79 | 80 | 81 | for ($lite.segments) -> $x { 82 | is($x.name,'ABC-3'); 83 | is($x.type,'similarity'); 84 | is($x.is_circular,False); 85 | } 86 | 87 | 88 | # build up a gene exon by exon 89 | my $e1 = Bio::SeqFeature::Lite.new(start=>1,stop=>100,type=>'exon'); 90 | my $e2 = Bio::SeqFeature::Lite.new(start=>150,stop=>200,type=>'exon'); 91 | my $e3 = Bio::SeqFeature::Lite.new(start=>300,stop=>500,type=>'exon'); 92 | $lite = Bio::SeqFeature::Lite.new(segments=>[$e1,$e2,$e3],type=>'gene',seq_id=>'123456'); 93 | 94 | is($e1.type,'exon'); 95 | is($e2.type,'exon'); 96 | is($e3.type,'exon'); 97 | is($e3.name,Any); 98 | 99 | is($lite.start,1,'correct start'); 100 | is($lite.stop,500,'correct stop'); 101 | is($lite.feature_count,3); 102 | is($lite.type,'gene'); 103 | is($lite.low(),'1'); 104 | is($lite.high(),'500'); 105 | is($lite.location_string,'1..100,150..200,300..500'); 106 | is($lite.score,Any); 107 | is($lite.length,500); 108 | is($lite.name,Any); 109 | 110 | #they should still keep their type as 'exon' 111 | for ($lite.segments) -> $x { 112 | is($x.type,'exon'); 113 | } 114 | -------------------------------------------------------------------------------- /nyi/t/SeqIO/fasta.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | 5 | eval_lives_ok 'use Bio::SeqIO', 'Can use Bio::SeqIO'; 6 | # eval_lives_ok 'use Bio::Role::FastaIO', 'Can use Bio::Role::FastaIO'; 7 | 8 | done(); 9 | -------------------------------------------------------------------------------- /t/00-meta.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use Test; 4 | constant AUTHOR = ?%*ENV; 5 | 6 | if AUTHOR { 7 | require Test::META <&meta-ok>; 8 | meta-ok; 9 | done-testing; 10 | } else { 11 | ok(1); 12 | done-testing; 13 | } 14 | -------------------------------------------------------------------------------- /t/Annotation/Comment.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | use Test; 5 | 6 | use Bio::Annotation::Comment; 7 | 8 | my $comment = Bio::Annotation::Comment.new( text => 'sometext'); 9 | does-ok($comment, Bio::Role::Annotation); 10 | is $comment.text, 'sometext'; 11 | is ~$comment, 'Comment: sometext'; 12 | 13 | done-testing(); 14 | -------------------------------------------------------------------------------- /t/Annotation/DBLink.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | use Test; 5 | 6 | use Bio::Annotation::DBLink; 7 | 8 | my $link1 = Bio::Annotation::DBLink.new(database => 'TSC', 9 | primary-id => 'TSC0000030', 10 | ); 11 | does-ok($link1, Bio::Role::Annotation); 12 | does-ok($link1, Bio::Role::Identifiable); 13 | 14 | is $link1.database, 'TSC'; 15 | is $link1.primary-id, 'TSC0000030'; 16 | is ~$link1, 'Direct database link to TSC0000030 in database TSC'; 17 | 18 | done-testing(); 19 | -------------------------------------------------------------------------------- /t/Annotation/Reference.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | =begin NOTE 6 | 7 | A bit on Bio::Annotation: this is a demo case that shows an Annotation class can 8 | be ported easily. The question now is: should it? 9 | 10 | =end NOTE 11 | 12 | use Test; 13 | 14 | use Bio::Annotation::Reference; 15 | 16 | my $ref = Bio::Annotation::Reference.new( authors => 'author line', 17 | title => 'title line', 18 | location => 'location line', 19 | database => 'MEDLINE', 20 | start => 12); 21 | 22 | does-ok($ref, Bio::Role::Annotation); 23 | does-ok($ref, Bio::Role::Range); 24 | isa-ok($ref, Bio::Annotation::DBLink); # TODO: this may change 25 | 26 | is $ref.authors, 'author line'; 27 | is $ref.title, 'title line'; 28 | is $ref.location, 'location line'; 29 | is $ref.start, 12; 30 | is $ref.database, 'MEDLINE'; 31 | is ~$ref, 'Reference: title line'; 32 | 33 | done-testing(); 34 | -------------------------------------------------------------------------------- /t/Annotation/SimpleValue.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | =begin NOTE 6 | 7 | A bit on Bio::Annotation: this is a demo case that shows an Annotation class can 8 | be ported easily. The question now is: should it? 9 | 10 | =end NOTE 11 | 12 | use Test; 13 | 14 | use Bio::Role::Annotation; 15 | 16 | { 17 | class TestAnnotation does Bio::Role::Annotation { 18 | 19 | has $.foo is rw; 20 | has $.bar is rw; 21 | 22 | method Str() { 23 | return self.foo ~ ':' ~ self.bar 24 | } 25 | 26 | method hash-tree() { 27 | return 'No hash tree here' 28 | } 29 | } 30 | } 31 | 32 | my $obj = TestAnnotation.new(:foo, :bar); 33 | 34 | does-ok( $obj, Bio::Role::Annotation); 35 | 36 | is( ~$obj, 'Hi:There', 'Stringifies as expected'); 37 | is( $obj.hash-tree, 'No hash tree here', 'hash-tree'); 38 | 39 | use Bio::Annotation::SimpleValue; 40 | 41 | #simple value 42 | my $simple = Bio::Annotation::SimpleValue.new(tag-name => 'colour', 43 | value => '1'); 44 | 45 | does-ok($simple, Bio::Role::Annotation); 46 | is ~$simple, 'Value: 1'; 47 | is $simple.value, 1; 48 | is $simple.tag-name, 'colour'; 49 | ok($simple.tag-term ~~ Any); 50 | is $simple.hash-tree.{'value'},1; 51 | $simple.value = 0; 52 | is $simple.value, 0; 53 | is ~$simple, 'Value: 0'; 54 | 55 | 56 | done-testing(); 57 | -------------------------------------------------------------------------------- /t/Grammar/FTLocation.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Grammar::FTLocation; 8 | 9 | ok(Bio::Grammar::FTLocation ~~ Grammar); 10 | 11 | { 12 | my $abs_ct = my $complex_ct = my $total_ct = 0; 13 | class Test::Actions { 14 | method TOP($/) { $total_ct++ } 15 | method absolute_location($/) { $abs_ct++ } 16 | method complex_location($/) { $complex_ct++ } 17 | }; 18 | 19 | my $fh = open($*SPEC.catfile(, :r)); 20 | 21 | # sorting is to keep the order constant from one run to the next 22 | while $fh.get -> $line { 23 | my ($locstr, *@rest) = split("\t", $line); 24 | Bio::Grammar::FTLocation.parse($locstr, :actions(Test::Actions.new())); 25 | ok($/.defined, $locstr); 26 | 27 | } 28 | 29 | $fh.close; 30 | is($total_ct, 38); 31 | is($abs_ct, 227); 32 | is($complex_ct, 121); 33 | } 34 | 35 | done-testing(); 36 | -------------------------------------------------------------------------------- /t/Grammar/Fasta.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | use Bio::Grammar::Fasta; 7 | 8 | class MyAction { 9 | method TOP ($/) { * } 10 | method record ($/) { * } 11 | method description_line ($/) { * } 12 | method id ($/) { * } 13 | method identifier ($/) { * } 14 | method generic_id ($/) { * } 15 | method description ($/) { * } 16 | method sequence ($/) { * } 17 | } 18 | 19 | my $fasta = q:to/FASTA/; 20 | >roa1_drome Rea guano receptor type III >> 0.1 21 | MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGLDYRTTDENLKAHEKWGNIVDVV 22 | VMKDPRTKRSRGFGFITYSHSSMIDEAQKSRPHKIDGRVEPKRAVPRQDIDSPNAGATVK 23 | KLFVGALKDDHDEQSIRDYFQHFGNIVDNIVIDKETGKKRGFAFVEFDDYDPVDKVVLQK 24 | QHQLNGKMVDVKKALPKNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGNQNGGGNWNNGGN 25 | NWGNNRGNDNWGNNSFGGGGGGGGGYGGGNNSWGNNNPWDNGNGGGNFGGGGNNWNGGND 26 | FGGYQQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGNYGNNQGFNNGGNNRRY 27 | >roa2_drome Rea guano ligand 28 | MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGLDYRTTDENLKAHEKWGNIVDVV 29 | VMKDPTSTSTSTSTSTSTSTSTMIDEAQKSRPHKIDGRVEPKRAVPRQDIDSPNAGATVK 30 | KLFVGALKDDHDEQSIRDYFQHLLLLLLLDLLLLDLLLLDLLLFVEFDDYDPVDKVVLQK 31 | QHQLNGKMVDVKKALPKNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGNQNGGGNWNNGGN 32 | NWGNNRGNDNWGNNSFGGGGGGGGGYGGGNNSWGNNNPWDNGNGGGNFGGGGNNWNGGND 33 | FGGYQQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGNYGNNQGFNNGGNNRRY 34 | FASTA 35 | 36 | my $actions = MyAction.new(); 37 | 38 | # parse string 39 | ok( Bio::Grammar::Fasta.parse( $fasta, :$actions)); 40 | is($/.from, 0); 41 | is($/.to, 804); 42 | 43 | # subparse a string, parse a file a record at a time 44 | ok( Bio::Grammar::Fasta.subparse( $fasta, :rule)); 45 | 46 | is($/.from, 0); 47 | is($/.to, 411); 48 | 49 | # TODO: not working, likely :pos is NYI in Rakudo 50 | ok( Bio::Grammar::Fasta.subparse( $fasta, :rule, :pos($/.to))); 51 | is($/.from, 411); 52 | is($/.to, 804); 53 | 54 | # parse file 55 | # TODO: use File::Spec-like path 56 | ok( Bio::Grammar::Fasta.parsefile($*SPEC.catfile( ) )); 57 | 58 | done-testing(); 59 | -------------------------------------------------------------------------------- /t/Location/Simple.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Location::Simple; 8 | use Bio::Type::Location; 9 | 10 | # set explicitly 11 | my $loc = Bio::Location::Simple.new(start => 1, end => 100, strand => -1); 12 | 13 | ok( Bio::Location::Simple ~~ Bio::Role::Location, 'does Location' ); 14 | ok( Bio::Location::Simple ~~ Bio::Role::Range, 'does Range' ); 15 | 16 | is($loc.start, 1, 'start'); 17 | is($loc.end, 100, 'end'); 18 | is($loc.length(), 100, 'length'); 19 | is($loc.strand, -1, 'strand'); 20 | is($loc.min-start, 1, 'min-start'); 21 | is($loc.max-start, 1, 'max-start'); 22 | is($loc.type, EXACT, 'type'); 23 | 24 | is($loc.min-end, 100, 'min-end'); 25 | is($loc.max-end, 100, 'max-end'); 26 | ok($loc.is-valid, 'is-valid'); 27 | ok(!$loc.is-remote, 'is-remote'); 28 | ok(!$loc.is-fuzzy, 'is-fuzzy'); 29 | is($loc, '1..100', 'Stringified'); 30 | 31 | # this should be remote but exact 32 | $loc = Bio::Location::Simple.new(seqid => 'ABC123', start => 1, end => 100, strand => -1); 33 | is($loc.type, EXACT, 'type'); 34 | ok($loc.is-valid, 'is-valid'); 35 | ok($loc.is-remote, 'is-remote'); 36 | ok(!$loc.is-fuzzy, 'is-fuzzy'); 37 | is($loc, 'ABC123:1..100', 'Stringified'); 38 | 39 | # this should be fuzzy 40 | $loc = Bio::Location::Simple.new(start => 1, end => 100, strand => -1, type => IN-BETWEEN); 41 | is($loc.type, IN-BETWEEN, 'type'); 42 | ok($loc.is-valid, 'is-valid'); 43 | ok(!$loc.is-remote, 'is-remote'); 44 | ok($loc.is-fuzzy, 'is-fuzzy'); 45 | is($loc, '1^100', 'Stringified'); 46 | 47 | # this should be fuzzy as well 48 | $loc = Bio::Location::Simple.new(start => 1, end => 100, strand => -1, start-pos-type => BEFORE); 49 | is($loc.type, EXACT, 'type'); 50 | ok($loc.is-valid, 'is-valid'); 51 | ok(!$loc.is-remote, 'is-remote'); 52 | ok($loc.is-fuzzy, 'is-fuzzy'); 53 | is($loc, '<1..100', 'Stringified'); 54 | 55 | $loc = Bio::Location::Simple.new(start => 1, end => 100, strand => -1, end-pos-type => AFTER); 56 | is($loc.type, EXACT, 'type'); 57 | ok($loc.is-valid, 'is-valid'); 58 | ok(!$loc.is-remote, 'is-remote'); 59 | ok($loc.is-fuzzy, 'is-fuzzy'); 60 | is($loc, '1..100>', 'Stringified'); 61 | 62 | done-testing(); 63 | -------------------------------------------------------------------------------- /t/PrimarySeq.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | 5 | use lib './lib'; 6 | 7 | eval-lives-ok 'use Bio::PrimarySeq', 'Can use Bio::PrimarySeq'; 8 | 9 | use Bio::PrimarySeq; 10 | use Bio::Type::Sequence; 11 | 12 | my $seq = Bio::PrimarySeq.new( 13 | seq => 'TTGGTGGCGTCAACT', 14 | display-id => 'new-id', 15 | alphabet => dna, 16 | accession => 'X677667', 17 | description => 'Sample Bio::Seq object' 18 | ); 19 | 20 | ok($seq ~~ Bio::PrimarySeq, 'Bio::PrimarySeq object'); 21 | 22 | 23 | is($seq.accession(), 'X677667','Retrieving accession number'); 24 | 25 | is($seq.seq(),'TTGGTGGCGTCAACT','Retrieving sequence'); 26 | is($seq.display-id,'new-id','Retrieving display_id'); 27 | 28 | is($seq.alphabet,dna,'Retrieving alphabet'); 29 | is($seq.alphabet.perl, 'SequenceType::dna', 'Alphabet is enum'); 30 | 31 | is($seq.is-circular, False,'Determining if circular'); 32 | $seq.is-circular=True; 33 | is($seq.is-circular, True,'Setting circular to True'); 34 | 35 | # check IdentifiableI and DescribableI interfaces 36 | ok($seq ~~ Bio::Role::Identifiable,'Has a Bio::Role::Identifiable'); 37 | ok($seq ~~ Bio::Role::Describable,'Has a Bio::Role::Describe'); 38 | 39 | # make sure all methods are implemented 40 | is(($seq.authority="bioperl.org") , "bioperl.org",'Setting authority'); 41 | is(($seq.namespace='t'),'t','Setting namespace'); 42 | is($seq.namespace, "t",'Retrieving namespace'); 43 | is(($seq.version=0), 0,'Setting version number'); 44 | is($seq.lsid-string(), "bioperl.org:t:X677667",'Retrieving lsid_string'); 45 | is($seq.namespace-string(), "t:X677667.0",'Retrieving namespace_string'); 46 | $seq.version=47; 47 | is($seq.version(), 47,'Retrieving version number'); 48 | is($seq.namespace-string(), "t:X677667.47",'Retrieving namespace_string'); 49 | is($seq.description(), 'Sample Bio::Seq object','Has correct description'); 50 | is($seq.display-name(), "new-id",'Has correct display_name'); 51 | 52 | # 53 | # length (gapless) 54 | # 55 | 56 | is($seq.length, 15, 'seq length'); 57 | 58 | # 59 | # revcom 60 | # 61 | 62 | my $rev = $seq.revcom(); 63 | ok($rev ~~ Bio::PrimarySeq, 'Bio::PrimarySeq object'); 64 | 65 | is($rev.seq(), 'AGTTGACGCCACCAA', 'revcom() failed, was ' ~ $rev.seq()); 66 | 67 | is($rev.display-id, 'new-id'); 68 | is( $rev.alphabet(), dna, 'alphabet copied through revcom' ); 69 | 70 | is( $rev.namespace, 't', 'namespace copied through revcom' ); 71 | is( $rev.namespace-string(), 72 | "t:X677667.47", 'namespace_string copied through revcom' ); 73 | is( $rev.is-circular, True, 'is_circular copied through revcom' ); 74 | 75 | # subseq 76 | is( $seq.subseq(start => 2, end => 5, strand => 1), 'TGGT', 'subseq normal'); 77 | is( $seq.subseq(start => 2, end => 5, strand => -1), 'ACCA', 'subseq, revcom' ); 78 | 79 | #my $location = Bio::Role::Location::Simple.new( 80 | # start => 2, 81 | # end => 5, 82 | # strand => -1 83 | #); 84 | 85 | #is( $seq.subseq($location), 'ACCA' ); 86 | 87 | #my $splitlocation = Bio::Role::Location::Split.new(); 88 | #$splitlocation.add_sub_Location( 89 | # Bio::Role::Location::Simple.new( 90 | # start => 1, 91 | # end => 4, 92 | # strand => 1 93 | # ) 94 | # ); 95 | # 96 | #$splitlocation.add_sub_Location( 97 | # Bio::Role::Location::Simple.new( 98 | # start => 7, 99 | # end => 12, 100 | # strand => -1 101 | # ) 102 | #); 103 | # 104 | #is( $seq.subseq($splitlocation), 'TTGGTGACGC' ); 105 | # 106 | #my $fuzzy = Bio::Role::Location::Fuzzy.new( 107 | # start => '<3', 108 | # end => '8', 109 | # strand => 1 110 | #); 111 | # 112 | #is( $seq.subseq($fuzzy), 'GGTGGC' ); 113 | # 114 | #my $trunc = $seq.trunc( 1, 4 ); 115 | #ok($trunc ~~ Bio::PrimarySeq, 'Bio::PrimarySeq object'); 116 | #is($trunc.seq(),'TTGG',"Expecting TTGG. Got " ~ $trunc.seq()); 117 | # 118 | #$trunc = $seq.trunc($splitlocation); 119 | #ok($trunc ~~ Bio::PrimarySeq, 'Bio::PrimarySeq object'); 120 | #is( $trunc.seq(), 'TTGGTGACGC' ); 121 | # 122 | #$trunc = $seq.trunc($fuzzy); 123 | #ok($trunc ~~ Bio::PrimarySeq, 'Bio::PrimarySeq object'); 124 | #is( $trunc.seq(), 'GGTGGC' ); 125 | 126 | 127 | # 128 | # Translate 129 | # 130 | 131 | my $aa = $seq.translate(); # TTG GTG GCG TCA ACT 132 | is($aa.seq, 'LVAST', "Translation: " ~ $aa.seq); 133 | 134 | # believe we are not going to support the old non named parameter format 135 | # tests for non-standard initiator codon coding for 136 | # M by making translate() look for an initiator codon and 137 | # terminator codon ("complete", the 5th argument below) 138 | 139 | # TODO: need to work out what we're testing; should focus on alternate starts 140 | # and not the old semantics of positional args, which won't be supported 141 | 142 | #$seq.seq ='TTGGTGGCGTCAACTTAA'; # TTG GTG GCG TCA ACT TAA 143 | #$aa = $seq.translate( start => 'ttg' ); 144 | #is($aa.seq, 'MVAST', "Translation: " ~ $aa.seq); 145 | 146 | # same test as previous, but using named parameter 147 | $aa = $seq.translate( complete => True ); 148 | is($aa.seq, 'MVAST', "Translation: " ~ $aa.seq); 149 | 150 | # find ORF, ignore codons outside the ORF or CDS 151 | $seq.seq = 'TTTTATGGTGGCGTCAACTTAATTT'; # ATG GTG GCG TCA ACT 152 | $aa = $seq.translate( orf => True ); 153 | is($aa.seq, 'MVAST*', "Translation: " ~ $aa.seq); 154 | 155 | ## smallest possible ORF 156 | $seq.seq ="ggggggatgtagcccc"; # atg tga 157 | $aa = $seq.translate( orf => True ); 158 | is($aa.seq, 'M*', "Translation: " ~ $aa.seq); 159 | 160 | # same as previous but complete, so * is removed 161 | $aa = $seq.translate( 162 | orf => True, 163 | complete => True 164 | ); 165 | is($aa.seq, 'M', "Translation: " ~ $aa.seq); 166 | 167 | # ORF without termination codon 168 | # should warn, let's change it into throw for testing 169 | 170 | # TODO: check exceptions here 171 | #$seq.verbose(2); 172 | #$seq.seq("ggggggatgtggcccc"); # atg tgg ccc 173 | #eval { $seq.translate( orf => 1 ); }; 174 | # 175 | #if $@ { 176 | # like( $@, qr/atgtggcccc\n/ ); 177 | # $seq.verbose(-1); 178 | # $aa = $seq.translate( orf => 1 ); 179 | # is($aa.seq, 'MWP', "Translation: " ~ $aa.seq; 180 | #} 181 | #$seq.verbose(0); 182 | 183 | # use non-standard codon table where terminator is read as Q 184 | $seq.seq = 'ATGGTGGCGTCAACTTAG'; # ATG GTG GCG TCA ACT TAG 185 | 186 | my $ct = Bio::Tools::CodonTable.new(id => 6); 187 | $aa = $seq.translate( codonTable => $ct ); 188 | 189 | is($aa.seq, 'MVASTQ' , "Translation: " ~ $aa.seq ); 190 | 191 | # insert an odd character instead of terminating with * 192 | $aa = $seq.translate( terminator => 'X' ); 193 | is($aa.seq, 'MVASTX' , "Translation: " ~ $aa.seq ); 194 | 195 | # change frame from default 196 | $aa = $seq.translate( frame => 1 ); # TGG TGG CGT CAA CTT AG 197 | is($aa.seq, 'WWRQL' , "Translation: " ~ $aa.seq ); 198 | 199 | $aa = $seq.translate( frame => 2 ); # GGT GGC GTC AAC TTA G 200 | is($aa.seq, 'GGVNL' , "Translation: " ~ $aa.seq ); 201 | 202 | # TTG is initiator in Standard codon table? Afraid so. 203 | $seq.seq ="ggggggttgtagcccc"; # ttg tag 204 | $aa = $seq.translate( orf => True ); 205 | is($aa.seq, 'L*' , "Translation: " ~ $aa.seq ); 206 | 207 | # Replace L at 1st position with M by setting complete to 1 208 | $seq.seq = "ggggggttgtagcccc"; # ttg tag 209 | $aa = $seq.translate( 210 | orf => True, 211 | complete => True 212 | ); 213 | is($aa.seq, 'M' , "Translation: " ~ $aa.seq ); 214 | 215 | # Ignore non-ATG initiators (e.g. TTG) in codon table 216 | $seq.seq ="ggggggttgatgtagcccc"; # atg tag 217 | $aa = $seq.translate( 218 | orf => True, 219 | start => "atg", 220 | complete => True 221 | ); 222 | is($aa.seq, 'M' , "Translation: " ~ $aa.seq ); 223 | $seq.seq = 'TTGGTGGCG?CAACT'; 224 | 225 | # test for character '?' in the sequence string 226 | is($seq.seq, 'TTGGTGGCG?CAACT'); 227 | 228 | # test that x's are ignored and n's are assumed to be dna no longer true! 229 | # See Bug 2438. There are protein sequences floating about which are all 'X' 230 | # (unknown aa) 231 | 232 | $seq.seq = 'atgxxxxxx'; 233 | $seq.set-alphabet; 234 | is( $seq.alphabet, 'protein' ); 235 | 236 | $seq.seq = 'atgnnnnnn'; 237 | $seq.set-alphabet; 238 | is( $seq.alphabet, dna ); 239 | 240 | ## Bug #2864: 241 | 242 | # Note this is now type-checked as a string, so we need to stringify Ints 243 | $seq = Bio::PrimarySeq.new( display-id => ~ 0, seq => 'GATC' ); 244 | 245 | is($seq.display-id, 0, "Bug #2864"); 246 | 247 | done-testing(); 248 | -------------------------------------------------------------------------------- /t/Range.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Role::Range; 8 | 9 | #=begin Range tests 10 | # 11 | #Test out simple ranges. Locations will expand on these... 12 | # 13 | # r0 |---------> 14 | # r1 |---------| 15 | # r2 <---------| 16 | # 17 | # r3 |--> 18 | # r4 |--| 19 | # r5 <--| 20 | # 21 | # r6 |--------> 22 | # r7 |--------| 23 | # r8 <--------| 24 | # 25 | # r9 |--------> 26 | # r10 |--------| 27 | # r11 <--------| 28 | # 29 | #Logic table for overlaps, contains, equals 30 | # 31 | #m = method, o = overlaps() c = contains() e = equals 32 | #st = strand tests, i = ignore, w = weak, s = strong 33 | # 34 | # r0 |r1 |r2 |r3 |r4 |r5 |r6 |r7 |r8 |r9 |r10 |r11 35 | # o c e |o c e |o c e |o c e |o c e |o c e |o c e |o c e |o c e |o c e |o c e |o c e 36 | # iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws|iwsiwsiws 37 | #r0 111111111|110110110|100100100|111111000|110110000|100100000|111000000|110000000|100000000|000000000|000000000|000000000 38 | #r1 xxxxxxxxx|110110110|110110110|110110000|110110000|110110000|110000000|110000000|110000000|000000000|000000000|000000000 39 | #r2 xxxxxxxxx|xxxxxxxxx|111111111|100100000|110110000|111111000|100000000|110000000|111000000|000000000|000000000|000000000 40 | #r3 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|111111111|110110110|100100100|111000000|110000000|100000000|000000000|000000000|000000000 41 | #r4 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|110110110|110110110|110000000|110000000|110000000|000000000|000000000|000000000 42 | #r5 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|111111111|100000000|110000000|111000000|000000000|000000000|000000000 43 | #r6 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|111111111|110110110|100100100|111000000|110000000|100000000 44 | #r7 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|110110110|110110110|110000000|110000000|110000000 45 | #r8 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|111111111|100000000|110000000|111000000 46 | #r9 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|111111111|110110110|100100100 47 | #r10 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|110110110|110110110 48 | #r11 xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|xxxxxxxxx|111111111 49 | # 50 | #=end Range tests 51 | 52 | class MyRange does Bio::Role::Range { 53 | method Str { 54 | '(' ~ $.start ~ ', ' ~ $.end ~ ')' ~ ' strand=' ~ $.strand; 55 | } 56 | }; 57 | 58 | # role 59 | 60 | my @spans = (1 => 100, 25 => 75, 75 => 125, 101 => 150); 61 | 62 | my @ranges; 63 | 64 | for @spans -> $s { 65 | for (-1..1).reverse -> $strand { 66 | @ranges.push(MyRange.new(start => $s.key, 67 | end => $s.value, 68 | strand => $strand)); 69 | } 70 | } 71 | 72 | ok(@ranges[0] ~~ Bio::Role::Range, 'Range role'); 73 | isa-ok(@ranges[0], MyRange, 'MyRange class'); 74 | ok(!@ranges[0].^isa(Bio::Role::Range), 'Role consumed by class'); 75 | is(@ranges[0].start, 1); 76 | is(@ranges[0].end, 100); 77 | is(@ranges[0].strand, 1); 78 | is(@ranges[0].length, 100); 79 | is(@ranges[1].strand, 0); 80 | is(@ranges[2].strand, -1); 81 | is(@ranges[11].start, 101); 82 | is(@ranges[11].end, 150); 83 | is(@ranges[11].strand, -1); 84 | is(@ranges[11].length, 50); 85 | 86 | # test overlaps, contains, equals, cover all variations 87 | 88 | my %map = ( 89 | r0 => '111111111|110110110|100100100|111111000|110110000|100100000|111000000|110000000|100000000|000000000|000000000|000000000', 90 | r1 => '110110110|110110110|110110000|110110000|110110000|110000000|110000000|110000000|000000000|000000000|000000000', 91 | r2 => '111111111|100100000|110110000|111111000|100000000|110000000|111000000|000000000|000000000|000000000', 92 | r3 => '111111111|110110110|100100100|111000000|110000000|100000000|000000000|000000000|000000000', 93 | r4 => '110110110|110110110|110000000|110000000|110000000|000000000|000000000|000000000', 94 | r5 => '111111111|100000000|110000000|111000000|000000000|000000000|000000000', 95 | r6 => '111111111|110110110|100100100|111000000|110000000|100000000', 96 | r7 => '110110110|110110110|110000000|110000000|110000000', 97 | r8 => '111111111|100000000|110000000|111000000', 98 | r9 => '111111111|110110110|100100100', 99 | r10 => '110110110|110110110', 100 | r11 => '111111111', 101 | ); 102 | 103 | for 0..@ranges.end -> $i { 104 | if %map{"r$i"}:exists { 105 | # must numerify match and then make it Bool 106 | my @tests = %map{"r$i"}.comb(/\d/).map: { ?+$_ }; 107 | for $i..@ranges.end -> $j { 108 | my $r1 = @ranges[$i]; 109 | my $r2 = @ranges[$j]; 110 | for -> $method { 111 | for -> $test { 112 | my $current = @tests.shift; 113 | is($r1."$method"($r2, :test($test) ), $current, "$r1 $method $r2, $test: $current"); 114 | } 115 | } 116 | } 117 | } 118 | } 119 | 120 | #=begin Geometric tests 121 | # 122 | #With these ranges: 123 | # 124 | # r0 |---------> 125 | # r1 |---------| 126 | # r2 <---------| 127 | # 128 | # r3 |--> 129 | # r4 |--| 130 | # r5 <--| 131 | # 132 | # r6 |--------> 133 | # r7 |--------| 134 | # r8 <--------| 135 | # 136 | # r9 |--------> 137 | # r10 |--------| 138 | # r11 <--------| 139 | # 140 | # intersection of r0, r3, r6 => [75,75,1] for all st 141 | # intersection of r6, r9 => [101, 125, 1] for all st 142 | # intersection of r6, r10 => [101, 125, 0] for ignore, weak, undef for strong 143 | # intersection of r6, r11 => [101, 125, 0] for ignore, undef for weak & strong 144 | # intersection of r0, r6, r9 => undef for all 145 | # 146 | # union of r0, r3, r6 => [1,125,1] for all st 147 | # union of r6, r9 => [75, 150, 1] for all st 148 | # union of r6, r10 => [75, 150, 0] for all st 149 | # union of r6, r11 => [75, 150, 0] for all st 150 | # union of r0, r6, r9 => [1,150,1] for all st 151 | # 152 | #=end Geometric tests 153 | 154 | my %geo_tests = 155 | ('0,3,6' => { # intersection union 156 | 'strong' => ['(75, 75) strand=1', '(1, 125) strand=1'], 157 | 'weak' => ['(75, 75) strand=1', '(1, 125) strand=1'], 158 | 'ignore' => ['(75, 75) strand=1', '(1, 125) strand=1'], 159 | }, 160 | '6,9' => { 161 | 'strong' => ['(101, 125) strand=1', '(75, 150) strand=1'], 162 | 'weak' => ['(101, 125) strand=1', '(75, 150) strand=1'], 163 | 'ignore' => ['(101, 125) strand=1', '(75, 150) strand=1'], 164 | }, 165 | '6,10' => { 166 | 'strong' => ['', '(75, 150) strand=0'], 167 | 'weak' => ['(101, 125) strand=0', '(75, 150) strand=0'], 168 | 'ignore' => ['(101, 125) strand=0', '(75, 150) strand=0'], 169 | }, 170 | '6,11' => { 171 | 'strong' => ['', '(75, 150) strand=0'], 172 | 'weak' => ['', '(75, 150) strand=0'], 173 | 'ignore' => ['(101, 125) strand=0', '(75, 150) strand=0'], 174 | }, 175 | '0,6,9' => { 176 | 'strong' => ['', '(1, 150) strand=1'], 177 | 'weak' => ['', '(1, 150) strand=1'], 178 | 'ignore' => ['', '(1, 150) strand=1'], 179 | }, 180 | ); 181 | 182 | for %geo_tests.keys.sort -> $set { 183 | my @rest = @ranges[$set.split(',')]; 184 | my $primary = @rest.shift; 185 | for -> $test { 186 | my $int = $primary.intersection(@rest, :$test); 187 | my $union = $primary.union(@rest, :$test); 188 | is(($int.defined ?? $int.Str !! ''), %geo_tests{$set}{$test}[0], "intersection of $set, $test"); 189 | is(($union.defined ?? $union.Str !! ''), %geo_tests{$set}{$test}[1], "union of $set, $test"); 190 | } 191 | } 192 | 193 | #=begin Subtraction 194 | # 195 | # r0 |---------> 196 | # r1 |---------| 197 | # r2 <---------| 198 | # 199 | # r3 |--> 200 | # r4 |--| 201 | # r5 <--| 202 | # 203 | # r6 |--------> 204 | # r7 |--------| 205 | # r8 <--------| 206 | # 207 | # r9 |--------> 208 | # r10 |--------| 209 | # r11 <--------| 210 | # 211 | # subtraction of r3 from r0 => two Ranges [1, 24, 1] and [76, 100, 1] 212 | # subtraction of r0 from r3 => one Range [0,0,1] - empty 213 | # subtraction of r6 from r0 => one Range [1, 74, 1] 214 | # subtraction of r0 from r6 => one Range [101,125,1] 215 | # subtraction of r9 from r6 => one Range [75,100,1] 216 | # subtraction of r6 from r9 => one Range [126,150,1] 217 | # subtraction of r9 from r0 => original (or clone?) r0 Range [1, 100, 1] 218 | # subtraction of r0 from r9 => original (or clone?) r9 Range [101,150,1] 219 | # 220 | #=end Subtraction 221 | 222 | my %subtract_tests = ( # rx->subtract(ry) ry->subtract(rx) 223 | '0,3' => { 224 | 'strong' => ['(1, 24) strand=1,(76, 100) strand=1','(0, 0) strand=0'], 225 | 'weak' => ['(1, 24) strand=1,(76, 100) strand=1','(0, 0) strand=0'], 226 | 'ignore' => ['(1, 24) strand=1,(76, 100) strand=1','(0, 0) strand=0'], 227 | }, 228 | '0,4' => { 229 | 'strong' => ['(1, 100) strand=1', '(25, 75) strand=0'], 230 | 'weak' => ['(1, 24) strand=1,(76, 100) strand=1','(0, 0) strand=0'], 231 | 'ignore' => ['(1, 24) strand=1,(76, 100) strand=1','(0, 0) strand=0'], 232 | }, 233 | '0,6' => { 234 | 'strong' => ['(1, 74) strand=1', '(101, 125) strand=1'], 235 | 'weak' => ['(1, 74) strand=1', '(101, 125) strand=1'], 236 | 'ignore' => ['(1, 74) strand=1', '(101, 125) strand=1'], 237 | }, 238 | '6,9' => { 239 | 'strong' => ['(75, 100) strand=1', '(126, 150) strand=1'], 240 | 'weak' => ['(75, 100) strand=1', '(126, 150) strand=1'], 241 | 'ignore' => ['(75, 100) strand=1', '(126, 150) strand=1'], 242 | }, 243 | '0,9' => { 244 | 'strong' => ['(1, 100) strand=1', '(101, 150) strand=1'], 245 | 'weak' => ['(1, 100) strand=1', '(101, 150) strand=1'], 246 | 'ignore' => ['(1, 100) strand=1', '(101, 150) strand=1'], 247 | }, 248 | ); 249 | 250 | for %subtract_tests.keys.sort -> $set { 251 | my ($r1, $r2) = @ranges[split(',',$set)]; 252 | for -> $st { 253 | my @sub1 = $r1.subtract($r2, test => $st); 254 | my @sub2 = $r2.subtract($r1, test => $st); 255 | is(join(',', @sub1».Str), %subtract_tests{$set}{$st}[0], "subtract" ); 256 | is(join(',', @sub2».Str), %subtract_tests{$set}{$st}[1], "subtract"); 257 | } 258 | } 259 | 260 | done-testing(); 261 | -------------------------------------------------------------------------------- /t/Role/Aliased.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Role::Aliased; 8 | 9 | class Stub { 10 | has $.a is aliased('foo', 'baz'); 11 | has $.long_name is aliased('bar'); 12 | }; 13 | 14 | my $test = Stub.new(:a, :long_name); 15 | 16 | is($test.a, 'hi there', ''); 17 | ok($test.can('foo'), 'adds alias'); 18 | ok($test.can('baz'), 'adds alias'); 19 | 20 | # Does not work, get "No such method 'foo' for invocant of type 'Stub'" 21 | is($test.foo, 'hi there'); 22 | is($test.baz, 'hi there'); 23 | 24 | is($test.long_name, 'Long time no see'); 25 | is($test.bar, 'Long time no see'); 26 | 27 | # TODO: add role tests... 28 | 29 | done-testing(); -------------------------------------------------------------------------------- /t/Role/Describable.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Role::Describable; 8 | 9 | class Desc does Bio::Role::Describable { }; 10 | 11 | my $s = Desc.new(display-name => , 12 | description => 'Hello, my name is Mr. Ed'); 13 | 14 | is($s.display-name, 'ABCD1234', 'test display_name'); 15 | is($s.description, 'Hello, my name is Mr. Ed', 'test description'); 16 | ok($s ~~ Bio::Role::Describable,'Has a Bio::Role::Describe'); 17 | 18 | $s.display-name = 'WXYZ4567'; 19 | $s.description = 'Goodbye, Mr. Bond'; 20 | 21 | is($s.display-name, 'WXYZ4567'); 22 | 23 | # testing aliases out 24 | is($s.description, 'Goodbye, Mr. Bond'); 25 | 26 | #is($s.desc, 'Goodbye, Mr. Bond'); # TODO: aliases don't work yet 27 | #$s.desc = 'Frankly, my dear...'; # TODO: set via alias 28 | #is($s.description, 'Frankly, my dear...'); 29 | 30 | done-testing(); 31 | -------------------------------------------------------------------------------- /t/Role/IO.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Role::IO; 8 | 9 | ok(1); 10 | 11 | { 12 | class MyIO does Bio::Role::IO { 13 | } 14 | } 15 | 16 | # simple file input 17 | my $in = MyIO.new( file => $*SPEC.catfile('t','data','test.fasta'), :r); 18 | 19 | ok($in ~~ Bio::Role::IO, 'does Bio::Role::IO'); 20 | is($in.file, $*SPEC.catfile('t','data','test.fasta')); # De-UNIX this 21 | 22 | isa-ok($in.fh, 'IO::Handle'); 23 | is($in.mode, 'r'); 24 | 25 | # simple file output 26 | my $out = MyIO.new( file => $*SPEC.catfile('hi.txt'), :w); 27 | 28 | is($out.file, 'hi.txt'); 29 | is($out.mode, 'w'); 30 | 31 | # rw 32 | my $inout = MyIO.new( file => $*SPEC.catfile('hi.txt'), :rw ); 33 | is($inout.mode, 'rw'); 34 | 35 | # also works with :r :w 36 | $inout = MyIO.new( file => $*SPEC.catfile('hi.txt'), :r, :w ); 37 | is($inout.mode, 'rw'); 38 | 39 | # from a file handle 40 | my $fh = $*SPEC.catfile('t','data','test.fasta').IO.open: :r; 41 | 42 | $in = MyIO.new( fh => $fh ); 43 | todo('Mode from a file handle NYI', 1); 44 | is($in.mode, 'r'); 45 | 46 | # if you really really have to use IO instead of SPEC for catfile, a'la old 47 | # BioPerl, but this will likely be deprecated in favor of $*SPEC 48 | is(MyIO.catfile('a', 'b', 'c'), $*SPEC.catfile('a', 'b', 'c'), 'catfile'); 49 | is(MyIO.catdir('a', 'b', 'c'), $*SPEC.catdir('a', 'b', 'c'), 'catdir'); 50 | 51 | done-testing(); 52 | 53 | END { 54 | unlink('hi.txt') if 'hi.txt'.IO:e; 55 | } 56 | -------------------------------------------------------------------------------- /t/Role/Identifiable.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | use Bio::Role::Identifiable; 7 | 8 | class Id does Bio::Role::Identifiable { }; 9 | 10 | my $s = Id.new(accession => 'Foo', 11 | authority => 'BioPerl6', 12 | namespace => 'GenBank', 13 | version => 12); 14 | 15 | ok($s ~~ Bio::Role::Identifiable,'Has a Bio::Role::Identifiable'); 16 | 17 | is($s.object-id, 'Foo'); 18 | is($s.accession, 'Foo'); 19 | is($s.authority, 'BioPerl6'); 20 | is($s.version, 12); 21 | is($s.namespace, 'GenBank'); 22 | 23 | is($s.lsid-string, 'BioPerl6:GenBank:Foo'); 24 | is($s.namespace-string, 'GenBank:Foo.12'); 25 | 26 | $s = Id.new(accession => 'Foo', 27 | authority => 'BioPerl6', 28 | namespace => 'GenBank'); 29 | 30 | is($s.object-id, 'Foo'); 31 | is($s.authority, 'BioPerl6'); 32 | ok(!$s.version); 33 | is($s.namespace, 'GenBank'); 34 | 35 | is($s.lsid-string, 'BioPerl6:GenBank:Foo'); 36 | is($s.namespace-string, 'GenBank:Foo'); 37 | 38 | done-testing(); 39 | -------------------------------------------------------------------------------- /t/Role/Pluggable.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib ('./lib', 't/lib'); 4 | 5 | # note this adds the path to @*INC to check for plugins 6 | 7 | use Test; 8 | 9 | use Bio::Role::Pluggable; 10 | 11 | class MyTest does Bio::Role::Pluggable['PluginDir'] { 12 | has %.testcase1 = 13 | 'MyTest::PluginDir::Plugin1' => True, 14 | 'MyTest::PluginDir::Plugin2' => True, 15 | 'MyTest::PluginDir::Plugin3' => False, 16 | ; 17 | 18 | method test() { 19 | my @plugins = @( $.plugins() ); 20 | 21 | my ($test, $count); 22 | $count = 0; 23 | for %.testcase1.keys -> $k { 24 | $test = False; 25 | for @plugins -> $p { 26 | $test = True, last if $p eq $k; 27 | } 28 | $count++ if True ~~ %.testcase1{$k}; 29 | is %.testcase1{$k}, $test, "Test: $k"; 30 | } 31 | } 32 | }; 33 | 34 | ok(1); 35 | 36 | MyTest.new.test(); 37 | 38 | done-testing(); 39 | -------------------------------------------------------------------------------- /t/Role/Temp.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Role::Temp; 8 | 9 | ok(1); 10 | 11 | my (@cleaned, @kept); 12 | 13 | { 14 | class MyTemp does Bio::Role::Temp { 15 | } 16 | } 17 | 18 | 19 | ################## 20 | # tempfile 21 | ################## 22 | 23 | my ($tfh,$tfile); 24 | 25 | { 26 | ok my $obj = MyTemp.new(); 27 | 28 | isa-ok $obj, 'MyTemp'; 29 | 30 | ok $obj ~~ Bio::Role::Temp; 31 | 32 | my $TEST_STRING = "Bioperl rocks!\n"; 33 | ($tfile, $tfh) = $obj.tempfile(); 34 | 35 | # check write 36 | isa-ok $tfh, 'IO::Handle'; 37 | $tfh.print($TEST_STRING); 38 | $tfh.close; 39 | 40 | # check read 41 | my $IN = $tfile.IO.open(:r) orelse die "Could not read file '$tfile': $!\n"; 42 | my $val = $IN.path.slurp; 43 | is $val, $TEST_STRING; 44 | $IN.close; 45 | 46 | ok $tfile.IO ~~ :e, 'File exists'; 47 | @cleaned.push: $tfile; 48 | 49 | todo('Current problems with END blocks and File::Temp',1); 50 | ok $tfile.IO !~~ :e, "tempfile $tfile deleted"; 51 | } 52 | 53 | ################## 54 | # tempdir 55 | ################## 56 | 57 | { 58 | my $obj = MyTemp.new(); 59 | 60 | my $tdir = $obj.tempdir(CLEANUP=>1); 61 | ok $tdir.IO ~~ :d; 62 | ($tfile, $tfh) = $obj.tempfile(:tempdir($tdir)); 63 | $tfh.close; 64 | ok $tfile.IO ~~ :e; 65 | @cleaned.push: $tfile; 66 | } 67 | 68 | 69 | ################## 70 | # tempfile 71 | # Unlink = 0 72 | ################## 73 | 74 | { 75 | my $obj = MyTemp.new(); 76 | ($tfile, $tfh) = $obj.tempfile(:!unlink); 77 | isa-ok $tfh, 'IO::Handle'; 78 | $tfh.close; 79 | ok $tfile.IO ~~ :e, ':e' ; 80 | $obj = Nil; 81 | 82 | ok $tfile.IO ~~ :e, 'UNLINK => 0'; 83 | @kept.push: $tfile; 84 | 85 | } 86 | 87 | { 88 | my $obj = MyTemp.new(); 89 | 90 | # check suffix is applied 91 | my ($tfile, $tfh) = $obj.tempfile(:suffix<.bioperl>); 92 | isa-ok $tfh, 'IO::Handle'; 93 | #like $tfh, rx/\.bioperl$/, 'tempfile suffix'; 94 | ok close $tfh; 95 | @cleaned.push: $tfile; 96 | 97 | ## check single return value mode of File::Temp 98 | #my $fh2 = $obj->tempfile; 99 | #isa-ok $fh2, 'GLOB'; 100 | #ok $fh2, 'tempfile() in scalar context'; 101 | #ok close $fh2; 102 | #} 103 | } 104 | 105 | 106 | #END { 107 | # for @cleaned -> $file { 108 | # todo('NYI; GC occurs when out of scope?', 1); 109 | # ok $file.IO !~~ :e, "tempfile $file deleted"; 110 | # } 111 | # 112 | # for @kept -> $file { 113 | # ok $file.IO ~~ :e, 'tempfile kept'; 114 | # } 115 | #} 116 | 117 | done-testing(); 118 | -------------------------------------------------------------------------------- /t/Root.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | plan 15; 7 | 8 | # replace throw/warn_not_implemented with built-in yada-yada variants 9 | 10 | use Bio::Root::Root; 11 | 12 | my $s = Bio::Root::Root.new(); 13 | 14 | ok($s.isa(Bio::Root::Root)); 15 | eval-dies-ok('$s.throw("foo")','throw'); 16 | lives-ok {$s.warn("foo")},'warn() does not die'; 17 | $s.warn("foo"); 18 | lives-ok {$s.debug("foo"),'debug() does not die'}; 19 | 20 | # test strictness 21 | $s.strict = 2; # convert warn to throw 22 | eval-dies-ok('$s.throw("foo")'); 23 | eval-dies-ok('$s.warn("foo")'); 24 | lives-ok {$s.debug("foo")}; 25 | 26 | # check inheritance 27 | class Foo is Bio::Root::Root {}; 28 | 29 | my $n = Foo.new(); 30 | 31 | ok($n.isa(Foo)); 32 | ok($n.isa(Bio::Root::Root)); 33 | eval-dies-ok('$n.throw("foo")'); 34 | lives-ok {$n.warn("foo")}; 35 | lives-ok {$n.debug("foo")}; 36 | $s.strict = 2; # convert warn to throw 37 | eval-dies-ok('$n.throw("foo")'); 38 | eval-dies-ok('$n.warn("foo")'); 39 | lives-ok {$n.debug("foo")}; 40 | 41 | done-testing(); 42 | -------------------------------------------------------------------------------- /t/SeqIO.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::SeqIO; 8 | 9 | ok(1); 10 | 11 | my $in = Bio::SeqIO.new(format => 'fasta'); 12 | 13 | is($in.format, 'fasta', 'format'); 14 | 15 | dies-ok { $in.format = 'fastq' }, 'readonly'; 16 | 17 | # no version or variant (these are optional) 18 | ok($in.format-version ~~ Any, 'version'); 19 | ok($in.format-variant ~~ Any, 'variant'); 20 | 21 | # explicit 22 | $in = Bio::SeqIO.new(format => 'fasta', 23 | format-version => 1.0, 24 | format-variant => 'old'); 25 | 26 | is($in.format, 'fasta', 'format'); 27 | is($in.format-version, 1.0, 'version'); 28 | dies-ok { $in.format-version = 2.0 }, 'readonly'; 29 | dies-ok { $in.format-variant = 'new'}, 'readonly'; 30 | 31 | is($in.format-variant, 'old', 'variant'); 32 | 33 | # format-variant 34 | $in = Bio::SeqIO.new(format => 'fasta-old', 35 | format-version => 1.0); 36 | 37 | is($in.format, 'fasta', 'format'); 38 | is($in.format-version, 1.0, 'version'); 39 | is($in.format-variant, 'old', 'variant'); 40 | 41 | dies-ok {Bio::SeqIO.new(format => "foo")}, 'dies with an unknown format'; 42 | 43 | done-testing(); 44 | -------------------------------------------------------------------------------- /t/SeqIO/fasta.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | 5 | use lib './lib'; 6 | 7 | use-ok 'Bio::SeqIO', 'Can use Bio::SeqIO'; 8 | 9 | # TODO: the use-ok above does not actually load module in, so we do it here. 10 | use Bio::SeqIO; 11 | use Bio::PrimarySeq; 12 | 13 | my $format = 'fasta'; 14 | my $seqio_obj = Bio::SeqIO.new(file => $*SPEC.catfile(), 15 | format => $format); 16 | 17 | isa-ok($seqio_obj, Bio::SeqIO); 18 | 19 | my @methods = ; 20 | for @methods -> $method { 21 | can-ok($seqio_obj, $method) || 22 | diag "$method method not implemented for $format"; 23 | } 24 | 25 | # checking the first sequence object 26 | my $seq_obj = $seqio_obj.next-Seq(); 27 | isa-ok($seq_obj, Bio::PrimarySeq); 28 | my %expected = 'seq' => 'MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGL' ~ 29 | 'DYRTTDENLKAHEKWGNIVDVVVMKDPRTKRSRGFGFI' ~ 30 | 'TYSHSSMIDEAQKSRPHKIDGRVEPKRAVPRQDIDSPN' ~ 31 | 'AGATVKKLFVGALKDDHDEQSIRDYFQHFGNIVDNIVI' ~ 32 | 'DKETGKKRGFAFVEFDDYDPVDKVVLQKQHQLNGKMVD' ~ 33 | 'VKKALPKNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGN' ~ 34 | 'QNGGGNWNNGGNNWGNNRGNDNWGNNSFGGGGGGGGGY' ~ 35 | 'GGGNNSWGNNNPWDNGNGGGNFGGGGNNWNGGNDFGGY' ~ 36 | 'QQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGN' ~ 37 | 'YGNNQGFNNGGNNRRY', 38 | 'length' => '358', 39 | 'primary-id' => 'roa1_drome', 40 | 'description' => rx:s/Rea guano receptor type III/, 41 | ; 42 | is($seq_obj.seq(), %expected{'seq'}, 'sequence'); 43 | is($seq_obj.length(), %expected{'length'}, 'length'); 44 | #is($seq_obj.primary-id(), %expected{'primary-id'}, 'primary-id'); 45 | like($seq_obj.description(), %expected{'description'}, 'description'); 46 | 47 | 48 | # checking the second sequence object 49 | my $seq_obj2 = $seqio_obj.next-Seq(); 50 | isa-ok($seq_obj2, Bio::PrimarySeq); 51 | my %expected2 = ('seq' => 'MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGL' ~ 52 | 'DYRTTDENLKAHEKWGNIVDVVVMKDPTSTSTSTSTST' ~ 53 | 'STSTSTMIDEAQKSRPHKIDGRVEPKRAVPRQDIDSPN' ~ 54 | 'AGATVKKLFVGALKDDHDEQSIRDYFQHLLLLLLLDLL' ~ 55 | 'LLDLLLLDLLLFVEFDDYDPVDKVVLQKQHQLNGKMVD' ~ 56 | 'VKKALPKNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGN' ~ 57 | 'QNGGGNWNNGGNNWGNNRGNDNWGNNSFGGGGGGGGGY' ~ 58 | 'GGGNNSWGNNNPWDNGNGGGNFGGGGNNWNGGNDFGGY' ~ 59 | 'QQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGN' ~ 60 | 'YGNNQGFNNGGNNRRY', 61 | 'length' => '358', 62 | 'primary-id' => 'roa2_drome', 63 | 'description' => rx:s/Rea guano ligand/, 64 | ); 65 | is($seq_obj2.seq(), %expected2{'seq'}, 'sequence'); 66 | is($seq_obj2.length(), %expected2{'length'}, 'length'); 67 | #is($seq_obj2.primary-id(), %expected2{'primary-id'}, 'primary-id'); 68 | like($seq_obj2.description(), %expected2{'description'}, 'description'); 69 | 70 | 71 | # IO::String tests 72 | # from testformats.pl 73 | #SKIP: { 74 | # my ($file, $type) = ("test.$format", $format); 75 | # my $filename = test_input_file($file); 76 | # open my $FILE, '<', $filename or die "Could not read file '$filename': $!\n"; 77 | # my @datain = <$FILE>; 78 | # close $FILE; 79 | # 80 | # my $in = new IO::String(join('', @datain)); 81 | # my $seqin = new Bio::SeqIO( -fh => $in, 82 | # -format => $type); 83 | # my $out = new IO::String; 84 | # my $seqout = new Bio::SeqIO( -fh => $out, 85 | # -format => $type); 86 | # my $seq; 87 | # while( defined($seq = $seqin->next_seq) ) { 88 | # $seqout->write_seq($seq); 89 | # } 90 | # $seqout->close(); 91 | # $seqin->close(); 92 | # my $strref = $out->string_ref; 93 | # my @dataout = map { $_."\n"} split(/\n/, $$strref ); 94 | # my @diffs = &diff( \@datain, \@dataout); 95 | # is(@diffs, 0, "$format format can round-trip"); 96 | # 97 | # if(@diffs && $verbose) { 98 | # foreach my $d ( @diffs ) { 99 | # foreach my $diff ( @$d ) { 100 | # chomp($diff->[2]); 101 | # print $diff->[0], $diff->[1], "\n>", $diff->[2], "\n"; 102 | # } 103 | # } 104 | # print "in is \n", join('', @datain), "\n"; 105 | # print "out is \n", join('',@dataout), "\n"; 106 | # } 107 | # 108 | #} 109 | 110 | # TODO: check other formats against fasta 111 | 112 | ## bug 1508 113 | ## test genbank, gcg, ace against fasta (should throw an exception on each) 114 | # 115 | #for my $file (qw(roa1.genbank test.gcg test.ace test.raw)) { 116 | # my $in = Bio::SeqIO->new(-file => test_input_file($file), 117 | # -format => 'fasta'); 118 | # throws_ok {$in->next_seq} 119 | # qr/The sequence does not appear to be FASTA format/, "dies with $file"; 120 | #} 121 | 122 | done-testing(); 123 | -------------------------------------------------------------------------------- /t/Tools/CodonTable.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | #eval_lives_ok 'use Bio::Tools::CodonTable', 'Can use Bio::Tools::CodonTable'; 8 | 9 | use Bio::PrimarySeq; 10 | use Bio::Type::Sequence; 11 | 12 | # create a table object by giving an ID 13 | # my $DEBUG = test_debug(); 14 | my $myCodonTable = Bio::Tools::CodonTable.new( id => 16); 15 | ok $myCodonTable; 16 | is $myCodonTable.id(), 16, '.id'; 17 | ok($myCodonTable ~~ Bio::Tools::CodonTable, 'Bio::Tools::CodonTable object'); 18 | 19 | # defaults to ID 1 "Standard" 20 | $myCodonTable = Bio::Tools::CodonTable.new(); 21 | is $myCodonTable.id(), 1, '.id'; 22 | 23 | # CodonTable is now immutable, can't change attributes 24 | dies-ok { $myCodonTable.id = 10 }; 25 | 26 | # change codon table 27 | $myCodonTable = Bio::Tools::CodonTable.new( id => 10); 28 | is $myCodonTable.id, 10, 'change .id'; 29 | is $myCodonTable.name(), 'Euplotid Nuclear'; 30 | 31 | # enumerate tables as object method 32 | my %table = $myCodonTable.tables(); 33 | is %table.keys.elems, 17; # currently 17 known tables 34 | is %table{11}, qw<"Bacterial">; 35 | 36 | # enumerate tables as class method 37 | #todo need to implement as class method in the future 38 | # %table = Bio::Tools::CodonTable.tables; 39 | # is %table.keys.elems, 17; # currently 17 known tables 40 | # is %table{23}, 'Thraustochytrium Mitochondrial'; 41 | 42 | # translate codons 43 | $myCodonTable = Bio::Tools::CodonTable.new(id => 1); 44 | 45 | is $myCodonTable.translate(''), '', 'Empty sequence translate'; 46 | 47 | my @ii = ; 48 | my @res = ; 49 | my $test = 1; 50 | for @ii Z @res -> ($dna, $aa) { 51 | is($myCodonTable.translate($dna), $aa, "$dna: $aa"); 52 | } 53 | ok ($test); 54 | is $myCodonTable.translate('ag'), '', 'ag:'; 55 | is $myCodonTable.translate('jj'), '', 'jj:'; 56 | is $myCodonTable.translate('jjg'), 'X', 'jjg:Z'; 57 | is $myCodonTable.translate('gt'), 'V', 'gt:V'; 58 | is $myCodonTable.translate('g'), '', 'gt:V'; 59 | 60 | # a more comprehensive test on ambiguous codes 61 | my $seq = " 62 | atgaaraayacmacracwackacyacsacvachacdacbacxagragyatmatwatyathcarcayc 63 | cmccrccwcckccyccsccvcchccdccbccxcgmcgrcgwcgkcgycgscgvcghcgdcgbcgxctmctrct 64 | wctkctyctsctvcthctdctbctxgargaygcmgcrgcwgckgcygcsgcvgchgcdgcbgcxggmggrggw 65 | ggkggyggsggvgghggdggbggxgtmgtrgtwgtkgtygtsgtvgthgtdgtbgtxtartaytcmtcrtcwt 66 | cktcytcstcvtchtcdtcbtcxtgyttrttytramgamggmgrracratrayytaytgytrsaasagsartaa"; 67 | 68 | $seq ~~ s:g/\s+//; 69 | #so can have syntax highlighting and tabbing in emacs ::g 70 | 71 | @ii = $seq.comb(/. ** 3/); 72 | 73 | #print join (' ', @ii), "\n" if( $DEBUG); 74 | my $prot = " 75 | MKNTTTTTTTTTTTRSIIIIQHPPPPPPPPPPPRRRRRRRRRRRLLLLLLLLLLLEDAAAAAAAAAAAGGG 76 | GGGGGGGGVVVVVVVVVVV*YSSSSSSSSSSSCLF*RRRBBBLLLZZZ*"; 77 | 78 | 79 | $prot ~~ s:g/\s//; 80 | #so can have syntax highlighting and tabbing in emacs ::g 81 | 82 | @res = $prot.comb(); 83 | 84 | # print join (' ', @res), "\n" if( $DEBUG ); 85 | $test = 1; 86 | for @ii Z @res -> ($dna,$aa) { 87 | is($myCodonTable.translate($dna), $aa, "$dna: $aa"); 88 | } 89 | 90 | ## reverse translate amino acids 91 | 92 | is $myCodonTable.revtranslate('U'), (); 93 | is $myCodonTable.revtranslate('O'), (); 94 | # NYI 95 | # is $myCodonTable.revtranslate('J'), ('att','atc','ata','tta','ttg','ctt','ctc','cta','ctg'); 96 | # is $myCodonTable.revtranslate('I'), ('att','atc','ata'); 97 | 98 | 99 | @ii = ; 100 | @res = ( 101 | [], 102 | [], 103 | [], 104 | [], 105 | [], 106 | [], 107 | [] 108 | ); 109 | 110 | $test = 1; 111 | for 0..@ii.end() -> $i { 112 | my @codonres = $myCodonTable.revtranslate(@ii[$i]); 113 | for 0..@codonres.end() -> $j { 114 | if (@codonres[$j] ne @res[$i][$j]) { 115 | $test = 0; 116 | # print $ii[$i], ': ', $codonres[$j], " ne ", 117 | # $res[$i][$j], "\n" if( $DEBUG); 118 | last; 119 | } 120 | } 121 | } 122 | ok $test; 123 | 124 | # boolean tests 125 | ok $myCodonTable.is_start_codon('ATG'); 126 | is $myCodonTable.is_start_codon('GGH'), 0; 127 | ok $myCodonTable.is_start_codon('HTG'); 128 | is $myCodonTable.is_start_codon('CCC'), 0; 129 | 130 | ok $myCodonTable.is_ter_codon('UAG'); 131 | ok $myCodonTable.is_ter_codon('TaG'); 132 | ok $myCodonTable.is_ter_codon('TaR'); 133 | ok $myCodonTable.is_ter_codon('tRa'); 134 | is $myCodonTable.is_ter_codon('ttA'), 0; 135 | 136 | ok $myCodonTable.is_unknown_codon('jAG'); 137 | ok $myCodonTable.is_unknown_codon('jg'); 138 | is $myCodonTable.is_unknown_codon('UAG'), 0; 139 | 140 | is $myCodonTable.translate_strict('ATG'), 'M'; 141 | 142 | # 143 | # adding a custom codon table 144 | # 145 | 146 | my @custom_table = 'FFLLSSSSYY**CC*WLLLL**PPHHQQR*RRIIIMT*TT*NKKSSRRV*VVAA*ADDEE*GGG', 147 | 'test1'; 148 | 149 | #changed inferface from p5 version. Since cannot have require parameter after optional, going to have pass the table first, 150 | #so we can have optional table name and starts 151 | 152 | ok my $custct = Bio::Tools::CodonTable.new(table => @custom_table[0], 153 | table-name => @custom_table[1]); 154 | 155 | is $custct.id, 24; 156 | is $myCodonTable.translate('atgaaraayacmacracwacka'), 'MKNTTTT'; 157 | is $custct.translate('atgaaraayacmacracwacka'), 'MKXXTTT'; 158 | 159 | # test doing this via Bio::PrimarySeq object 160 | 161 | ok $seq = Bio::PrimarySeq.new(seq=>'atgaaraayacmacracwacka', alphabet=> dna); 162 | is $seq.translate().seq, 'MKNTTTT','Bio::PrimarySeq translate'; 163 | is $seq.translate(codonTable => $custct).seq, 'MKXXTTT'; 164 | 165 | # test gapped translated 166 | ok $seq = Bio::PrimarySeq.new(seq => 'atg---aar------aay', 167 | alphabet => dna); 168 | is $seq.translate.seq, 'M-K--N'; 169 | 170 | # NYI 171 | # ok $seq = Bio::PrimarySeq.new(seq =>'ASDFGHKL'); 172 | # is $myCodonTable.reverse_translate_all($seq), 'GCBWSNGAYTTYGGVCAYAARYTN'; 173 | # ok $seq = Bio::PrimarySeq.new(seq => 'ASXFHKL'); 174 | # is $myCodonTable.reverse_translate_all($seq), 'GCBWSNNNNTTYCAYAARYTN'; 175 | 176 | # 177 | # test reverse_translate_best(), requires a Bio::CodonUsage::Table object 178 | # 179 | # use_ok('Bio::CodonUsage::IO'); 180 | #ok $seq = Bio::PrimarySeq.new(seq =>'ACDEFGHIKLMNPQRSTVWY'); 181 | #ok my $io = Bio::CodonUsage::IO.new(-file => test_input_file('MmCT')); 182 | #ok my $cut = $io.next_data(); 183 | #is $myCodonTable.reverse_translate_best($seq,$cut), 'GCCTGCGACGAGTTCGGCCACATCAAGCTGATGAACCCCCAGCGCTCCACCGTGTGGTAC'; 184 | 185 | done-testing(); 186 | -------------------------------------------------------------------------------- /t/Tools/FTLocationParser.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | use Bio::Tools::FTLocationParser; 8 | 9 | my $parser = Bio::Tools::FTLocationParser.new(); 10 | 11 | ok(1); 12 | 13 | my $fh = open('t/data/location_data.txt', :r); 14 | 15 | my $ct = 0; 16 | while $fh.get -> $line { 17 | my ($locstr, *@rest) = split("\t", $line); 18 | $parser.from-string($locstr); 19 | last if $ct++ == 3; 20 | #Bio::Grammar::FTLocation.parse($locstr, :actions(Test::Actions.new())); 21 | #ok($/.defined, $locstr); 22 | } 23 | 24 | $fh.close; 25 | 26 | done-testing(); 27 | -------------------------------------------------------------------------------- /t/Tools/IUPAC.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | eval-lives-ok 'use Bio::Tools::IUPAC', 'Can use Bio::Tools::IUPAC'; 8 | eval-lives-ok 'use Bio::PrimarySeq', 'Can use Bio::PrimarySeq'; 9 | 10 | use Bio::Tools::IUPAC; 11 | use Bio::PrimarySeq; 12 | use Bio::Type::Sequence; # pull in types 13 | 14 | # test IUPAC 15 | 16 | my %IUB = ( 'A' => [< A >], 17 | 'C' => [< C >], 18 | 'G' => [< G >], 19 | 'T' => [< T >], 20 | 'U' => [< U >], 21 | 'M' => [], 22 | 'R' => [], 23 | 'W' => [], 24 | 'S' => [], 25 | 'Y' => [], 26 | 'K' => [], 27 | 'V' => [], 28 | 'H' => [], 29 | 'D' => [], 30 | 'B' => [], 31 | 'X' => [], 32 | 'N' => [] 33 | ); 34 | 35 | my %REV_IUB = ('A' => 'A', 36 | 'T' => 'T', 37 | 'C' => 'C', 38 | 'G' => 'G', 39 | 'AC' => 'M', 40 | 'AG' => 'R', 41 | 'AT' => 'W', 42 | 'CG' => 'S', 43 | 'CT' => 'Y', 44 | 'GT' => 'K', 45 | 'ACG' => 'V', 46 | 'ACT' => 'H', 47 | 'AGT' => 'D', 48 | 'CGT' => 'B', 49 | 'ACGT' => 'N', 50 | 'N' => 'N' 51 | ); 52 | 53 | 54 | my %IUP = ('A' => [], 55 | 'B' => [], 56 | 'C' => [], 57 | 'D' => [], 58 | 'E' => [], 59 | 'F'=> [], 60 | 'G' => [], 61 | 'H' => [], 62 | 'I' => [], 63 | 'J' => [], 64 | 'K' => [], 65 | 'L' => [], 66 | 'M' => [], 67 | 'N' => [], 68 | 'O' => [], 69 | 'P' => [

], 70 | 'Q' => [], 71 | 'R' => [], 72 | 'S' => [], 73 | 'T' => [], 74 | 'U' => [], 75 | 'V' => [], 76 | 'W' => [], 77 | 'X' => [], 78 | 'Y' => [], 79 | 'Z' => [], 80 | '*' => ['*'] 81 | ); 82 | 83 | 84 | my $ambiseq = Bio::PrimarySeq.new(seq => 'ARTCGTTGR', 85 | alphabet => dna); 86 | 87 | my $stream = Bio::Tools::IUPAC.new(seq => $ambiseq); 88 | is $stream.count(), 4; 89 | 90 | #this is pretty useless but still test it anyway. Probably get rid of this api later 91 | is-deeply($stream.iupac_iub(),%IUB,'Can access IUB hash from method call'); 92 | is-deeply($stream.iupac_rev_iub(),%REV_IUB,'Can access REV_IUB hash from method call'); 93 | is-deeply($stream.iupac_iup(),%IUP,'Can access IUP hash from method call'); 94 | 95 | is-deeply(%Bio::Tools::IUPAC::IUB,%IUB,'Can access IUB hash as a class variable'); 96 | is-deeply(%Bio::Tools::IUPAC::REV_IUB,%REV_IUB,'Can access REV_IUB hash as a class variable'); 97 | is-deeply(%Bio::Tools::IUPAC::IUP,%IUP,'Can access IUP hash as a class variable'); 98 | 99 | my $b = 1; 100 | while (my $uniqueseq = $stream.next_seq()) { 101 | if ( ! $uniqueseq ~~ Bio::PrimarySeq ) { 102 | $b = 0; 103 | last; # no point continuing if we get here 104 | } 105 | } 106 | ok $b; 107 | 108 | done-testing(); 109 | -------------------------------------------------------------------------------- /t/Types.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use lib './lib'; 4 | 5 | use Test; 6 | 7 | # TODO: these should probably become enums 8 | subset SeqAlphabet of Str where .lc ~~ any ; 9 | subset SeqStrandInt of Int where any < -1 0 1 >; 10 | subset SeqStrandChar of Str where any < - . + >; 11 | subset SeqStrand where any(SeqStrandChar, SeqStrandInt); 12 | 13 | for -2..2 -> $a { 14 | if -1 <= $a <= 1 { 15 | ok($a ~~ SeqStrandInt, "$a isa SeqStrandInt"); 16 | ok($a !~~ SeqStrandChar, "$a not a SeqStrandChar"); 17 | ok($a ~~ SeqStrand, "$a isa SeqStrand"); 18 | } else { 19 | ok($a !~~ SeqStrand, "$a is not a SeqStrand"); 20 | } 21 | } 22 | 23 | for -> $a { 24 | if $a eq any <. + -> { 25 | ok($a ~~ SeqStrandChar, "$a isa SeqStrandChar"); 26 | ok($a !~~ SeqStrandInt, "$a not a SeqStrandInt"); 27 | ok($a ~~ SeqStrand, "$a isa SeqStrand"); 28 | } else { 29 | ok($a !~~ SeqStrand, "$a is not a SeqStrand"); 30 | } 31 | } 32 | 33 | ok('dna' ~~ SeqAlphabet, 'some alphabet tests'); 34 | ok('DNA' ~~ SeqAlphabet); 35 | ok('rna' ~~ SeqAlphabet); 36 | ok('protein' ~~ SeqAlphabet); 37 | ok('foo' !~~ SeqAlphabet); 38 | 39 | done-testing(); 40 | -------------------------------------------------------------------------------- /t/data/canonical.gff3: -------------------------------------------------------------------------------- 1 | ##gff-version 3 2 | ##sequence-region ctg123 1 1497228 3 | ctg123 . gene 1000 9000 . + . ID=gene00001;Name=EDEN 4 | ctg123 . TF_binding_site 1000 1012 . + . Parent=gene00001 5 | ctg123 . mRNA 1050 9000 . + . ID=mRNA00001;Parent=gene00001 6 | ctg123 . mRNA 1050 9000 . + . ID=mRNA00002;Parent=gene00001 7 | ctg123 . mRNA 1300 9000 . + . ID=mRNA00003;Parent=gene00001 8 | ctg123 . exon 1300 1500 . + . Parent=mRNA00003 9 | ctg123 . exon 1050 1500 . + . Parent=mRNA00001,mRNA00002 10 | ctg123 . exon 3000 3902 . + . Parent=mRNA00001,mRNA00003 11 | ctg123 . exon 5000 5500 . + . Parent=mRNA00001,mRNA00002,mRNA00003 12 | ctg123 . exon 7000 9000 . + . Parent=mRNA00001,mRNA00002,mRNA00003 13 | ctg123 . CDS 1201 1500 . + 0 ID=cds00001;Parent=mRNA00001 14 | ctg123 . CDS 3000 3902 . + 0 ID=cds00001;Parent=mRNA00001 15 | ctg123 . CDS 5000 5500 . + 0 ID=cds00001;Parent=mRNA00001 16 | ctg123 . CDS 7000 7600 . + 0 ID=cds00001;Parent=mRNA00001 17 | ctg123 . CDS 1201 1500 . + 0 ID=cds00002;Parent=mRNA00002 18 | ctg123 . CDS 5000 5500 . + 0 ID=cds00002;Parent=mRNA00002 19 | ctg123 . CDS 7000 7600 . + 0 ID=cds00002;Parent=mRNA00002 20 | ctg123 . CDS 3301 3902 . + 0 ID=cds00003;Parent=mRNA00003 21 | ctg123 . CDS 5000 5500 . + 1 ID=cds00003;Parent=mRNA00003 22 | ctg123 . CDS 7000 7600 . + 1 ID=cds00003;Parent=mRNA00003 23 | ctg123 . CDS 3391 3902 . + 0 ID=cds00004;Parent=mRNA00003 24 | ctg123 . CDS 5000 5500 . + 1 ID=cds00004;Parent=mRNA00003 25 | ctg123 . CDS 7000 7600 . + 1 ID=cds00004;Parent=mRNA00003 -------------------------------------------------------------------------------- /t/data/location_data.txt: -------------------------------------------------------------------------------- 1 | 467 0 467 467 EXACT 467 467 EXACT EXACT 0 1 2 | 340..565 0 340 340 EXACT 565 565 EXACT EXACT 0 1 3 | <345..500 0 345 BEFORE 500 500 EXACT EXACT 0 1 4 | <1..888 0 1 BEFORE 888 888 EXACT EXACT 0 1 5 | (102.110) 0 102 102 EXACT 110 110 EXACT WITHIN 0 1 6 | (23.45)..600 0 23 45 WITHIN 600 600 EXACT EXACT 0 1 7 | (122.133)..(204.221) 0 122 133 WITHIN 204 221 WITHIN EXACT 0 1 8 | 123^124 0 123 123 EXACT 124 124 EXACT IN-BETWEEN 0 1 9 | 145^146 0 145 145 EXACT 146 146 EXACT IN-BETWEEN 0 1 10 | J00194:100..202 0 100 100 EXACT 202 202 EXACT EXACT 0 1 J00194 11 | ?2465..2774 0 2465 2465 UNCERTAIN 2774 2774 EXACT EXACT 0 1 12 | 22..?64 0 22 22 EXACT 64 64 UNCERTAIN EXACT 0 1 13 | ?22..?64 0 22 22 UNCERTAIN 64 64 UNCERTAIN EXACT 0 1 14 | ?..>393 0 UNCERTAIN 393 AFTER EXACT 0 1 15 | <1..? 0 1 BEFORE UNCERTAIN EXACT 0 1 16 | ?..536 0 UNCERTAIN 536 536 EXACT EXACT 0 1 17 | 1..? 0 1 1 EXACT UNCERTAIN EXACT 0 1 18 | ?..? 0 UNCERTAIN UNCERTAIN EXACT 0 1 19 | 1..?12 0 1 1 EXACT 12 12 UNCERTAIN EXACT 0 1 20 | ? 0 UNCERTAIN EXACT EXACT 0 1 21 | join(AY016290.1:108..185,AY016291.1:1546..1599) 0 EXACT EXACT JOIN 2 0 22 | complement(join(3207..4831,5834..5902,8881..8969,9276..9403,29535..29764)) 0 3207 3207 EXACT 29764 29764 EXACT JOIN 5 -1 23 | join(complement(29535..29764),complement(9276..9403),complement(8881..8969),complement(5834..5902),complement(3207..4831)) complement(join(3207..4831,5834..5902,8881..8969,9276..9403,29535..29764)) 3207 3207 EXACT 29764 29764 EXACT JOIN 5 -1 24 | join(12..78,134..202) 0 12 12 EXACT 202 202 EXACT JOIN 2 1 25 | join(<12..78,134..202) 0 12 BEFORE 202 202 EXACT JOIN 2 1 26 | complement(join(2691..4571,4918..5163)) 0 2691 2691 EXACT 5163 5163 EXACT JOIN 2 -1 27 | complement(join(4918..5163,2691..4571)) 0 2691 2691 EXACT 5163 5163 EXACT JOIN 2 -1 28 | join(complement(4918..5163),complement(2691..4571)) complement(join(2691..4571,4918..5163)) 2691 2691 EXACT 5163 5163 EXACT JOIN 2 -1 29 | join(complement(2691..4571),complement(4918..5163)) complement(join(4918..5163,2691..4571)) 2691 2691 EXACT 5163 5163 EXACT JOIN 2 -1 30 | complement(34..(122.126)) 0 34 34 EXACT 122 126 WITHIN EXACT 0 -1 31 | join(11025..11049,join(complement(239890..240081),complement(241499..241580),complement(251354..251412),complement(315036..315294))) join(11025..11049,complement(join(315036..315294,251354..251412,241499..241580,239890..240081))) 11025 11025 EXACT 315294 315294 EXACT JOIN 2 0 32 | join(11025..11049,complement(join(315036..315294,251354..251412,241499..241580,239890..240081))) 0 11025 11025 EXACT 315294 315294 EXACT JOIN 2 0 33 | join(20464..20694,21548..22763,complement(join(314652..314672,232596..232990,231520..231669))) 0 20464 20464 EXACT 314672 314672 EXACT JOIN 3 0 34 | join(20464..20694,21548..22763,join(complement(231520..231669),complement(232596..232990),complement(314652..314672))) join(20464..20694,21548..22763,complement(join(314652..314672,232596..232990,231520..231669))) 20464 20464 EXACT 314672 314672 EXACT JOIN 3 0 35 | join(1000..2000,join(3000..4000,join(5000..6000,7000..8000)),9000..10000) 0 1000 1000 EXACT 10000 10000 EXACT JOIN 3 1 36 | order(S67862.1:72..75,1..788,S67864.1:1..19) 0 EXACT EXACT ORDER 3 0 37 | join(GL002586.1:1..34478191,gap(100000),GL002587.1:1..43354415) 0 EXACT EXACT ORDER 3 0 38 | join(ACZS01000113.1:1..31090,gap(50),ACZS01000114.1:1..32367,gap(300),ACZS01000115.1:1..23926,gap(50),ACZS01000116.1:1..37939,gap(50),ACZS01000117.1:1..2415,gap(498),ACZS01000118.1:1..90824,gap(249),ACZS01000119.1:1..20094,gap(1288),ACZS01000120.1:1..7526,gap(50),ACZS01000121.1:1..8396,gap(916),ACZS01000122.1:1..4711,gap(50),ACZS01000123.1:1..7610,gap(50),ACZS01000124.1:1..13068,gap(471),ACZS01000125.1:1..2062,gap(274),ACZS01000126.1:1..36253,gap(50),ACZS01000127.1:1..17718,gap(50),ACZS01000128.1:1..56336,gap(355),ACZS01000129.1:1..14298,gap(328),ACZS01000130.1:1..16632,gap(360),ACZS01000131.1:1..29485,gap(1163),ACZS01000132.1:1..61637,gap(50),ACZS01000133.1:1..2189,gap(415),ACZS01000134.1:1..2638,gap(268),ACZS01000135.1:1..3234,gap(399),ACZS01000136.1:1..36276,gap(50),ACZS01000137.1:1..37251,gap(320),ACZS01000138.1:1..23265,gap(226),ACZS01000139.1:1..1945,gap(330),ACZS01000140.1:1..3783,gap(165),ACZS01000141.1:1..41750,gap(226),ACZS01000142.1:1..3866,gap(220),ACZS01000143.1:1..8883,gap(161),ACZS01000144.1:1..4681,gap(50),ACZS01000145.1:1..23948,gap(228),ACZS01000146.1:1..2990,gap(388),ACZS01000147.1:1..9633,gap(259),ACZS01000148.1:1..9932,gap(261),ACZS01000149.1:1..1565,gap(1288),ACZS01000150.1:1..60690,gap(425),ACZS01000151.1:1..65167,gap(50),ACZS01000152.1:1..46726,gap(50),ACZS01000153.1:1..18917,gap(510),ACZS01000154.1:1..22264,gap(50),ACZS01000155.1:1..37797,gap(729),ACZS01000156.1:1..9564,gap(569),ACZS01000157.1:1..2030,gap(362),ACZS01000158.1:1..5937,gap(287),ACZS01000159.1:1..28478,gap(267),ACZS01000160.1:1..12114,gap(218),ACZS01000161.1:1..26732,gap(616),ACZS01000162.1:1..11090,gap(330),ACZS01000163.1:1..26447,gap(224),ACZS01000164.1:1..2114,gap(225),ACZS01000165.1:1..75967,gap(96),ACZS01000166.1:1..67895,gap(1838),ACZS01000167.1:1..10047,gap(634),ACZS01000168.1:1..28315,gap(50),ACZS01000169.1:1..25678,gap(309),ACZS01000170.1:1..2746,gap(439),ACZS01000171.1:1..13328,gap(2838),ACZS01000172.1:1..567,gap(627),ACZS01000173.1:1..1451,gap(544),ACZS01000174.1:1..2654,gap(572),ACZS01000175.1:1..1758,gap(1463),ACZS01000176.1:1..1978,gap(613),ACZS01000177.1:1..8076,gap(1120),ACZS01000178.1:1..5510,gap(275),ACZS01000179.1:1..3481,gap(159),ACZS01000180.1:1..35889,gap(50),ACZS01000181.1:1..27693,gap(50),ACZS01000182.1:1..21337,gap(261),ACZS01000183.1:1..9546,gap(324),ACZS01000184.1:1..16424,gap(158),ACZS01000185.1:1..44270,gap(1288),ACZS01000186.1:1..12351,gap(143),ACZS01000187.1:1..3169,gap(50),ACZS01000188.1:1..13970) 0 EXACT EXACT ORDER 3 0 39 | -------------------------------------------------------------------------------- /t/data/multi_1.fa: -------------------------------------------------------------------------------- 1 | >gi|239758|bbs|68379 glucocorticoid receptor, GR [human, Peptide Partial, 394 aa] 2 | MDSKESLTPGREENPSSVLAQERGDVMDFYKTLRGGATVKVSASSPSLAVASQSDSKQRRLLVDFPKGSV 3 | >gi|239752|bbs|68871 PML-3=putative zinc finger protein [human, Peptide, 802 aa] 4 | MPPPETPSEGRQPSPSPSPTERAPASEEEFQFLRCQQCQAEAKCPKLLPCLHTLCSGCLEASGMQCPICQ 5 | >gi|238775|bbs|65126 putative tyrosine kinase receptor=UFO [human, NIH3T3, Peptide, 894 aa] 6 | MAWRCPRMGRVPLAWCLALCGWACMAPRGTQAEESPFVGNPGNITGARGLTGTLRCQLQVQGEPPEVHWL 7 | >gi|239006|bbs|65162 alpha(1,3)-fucosyltransferase, ELFT [human, Peptide, 400 aa] 8 | MGAPWGSPTAAAGGRRGWRRGRGLPWTVCVLAAAGLTCTALITYACWGQLPPLPWASPTPSRPVGVLLWW 9 | >gi|237597|bbs|60089 putative adhesion molecule=ADMLX [human, Peptide, 679 aa] 10 | MVPGVPGAVLTLCLWLAASSGSWRPAPARLCAAAGRVAVCRERPARSCASRCLSLQITRISAFFQHFQNN 11 | >gi|237995|bbs|62046 NK-1 receptor [human, lung, Peptide, 407 aa] 12 | MDNVLPVDSDLSPNISTNTSEPNQFVQPAWEIVLWAAAYTVIVVTSVVGNVVVMWIILAHKRMRTVTNYF 13 | 14 | 15 | -------------------------------------------------------------------------------- /t/data/roa1.genbank: -------------------------------------------------------------------------------- 1 | LOCUS AI129902 37 bp mRNA EST 27-OCT-1998 2 | DEFINITION qc41b07.x1 Soares_pregnant_uterus_NbHPU Homo sapiens cDNA clone 3 | IMAGE:1712149 3' similar to SW:ROA1_SCHAM P21522 HETEROGENEOUS 4 | NUCLEAR RIBONUCLEOPROTEIN A1, A2/B1 HOMOLOG. ;contains MSR1.b2 MSR1 5 | repetitive element ;, mRNA sequence. 6 | ACCESSION AI129902 7 | NID g3598416 8 | VERSION AI129902.1 GI:3598416 9 | KEYWORDS EST. 10 | SOURCE human. 11 | ORGANISM Homo sapiens 12 | Eukaryota; Metazoa; Chordata; Craniata; Vertebrata; Mammalia; 13 | Eutheria; Primates; Catarrhini; Hominidae; Homo. 14 | REFERENCE 1 (bases 1 to 37) 15 | AUTHORS NCI-CGAP http://www.ncbi.nlm.nih.gov/ncicgap. 16 | TITLE National Cancer Institute, Cancer Genome Anatomy Project (CGAP), 17 | Tumor Gene Index 18 | JOURNAL Unpublished (1997) 19 | COMMENT On May 8, 1995 this sequence version replaced gi:800643 20 | 21 | Contact: Robert Strausberg, Ph.D. 22 | Tel: (301) 496-1550 23 | Email: Robert_Strausberg@nih.gov 24 | This clone is available royalty-free through LLNL ; contact the 25 | IMAGE Consortium (info@image.llnl.gov) for further information. 26 | Trace considered overall poor quality 27 | Insert Length: 525 Std Error: 0.00 28 | Seq primer: -40m13 fwd. ET from Amersham 29 | High quality sequence stop: 1. 30 | FEATURES Location/Qualifiers 31 | source 1..37 32 | /organism="Homo sapiens" 33 | /db_xref="taxon:9606" 34 | /clone="IMAGE:1712149" 35 | /clone_lib="Soares_pregnant_uterus_NbHPU" 36 | /sex="female" 37 | /dev_stage="adult" 38 | /lab_host="DH10B" 39 | /note="Organ: uterus; Vector: pT7T3-Pac; Site_1: Not I; 40 | Site_2: Eco RI; 1st strand cDNA was primed with a Not I - 41 | oligo(dT) primer [5' 42 | AACTGGAAGAATTCGCGGCCGCCTTTTTTTTTTTTTTTTTT 3'], 43 | double-stranded cDNA was ligated to Eco RI adaptors 44 | (Pharmacia), digested with Not I and cloned into the Not I 45 | and Eco RI sites of the modified pT7T3 vector. Library 46 | went through one round of normalization. Library 47 | constructed by M. Fatima Bonaldo." 48 | BASE COUNT 5 a 28 c 2 g 2 t 49 | ORIGIN 50 | 1 ctccgcgcca actcccccca cccccccccc acacccc 51 | // 52 | LOCUS BAB68554 141 aa linear VRT 11-APR-2002 53 | DEFINITION alpha D-globin [Aldabrachelys elephantina]. 54 | ACCESSION BAB68554 55 | PID g15824047 56 | VERSION BAB68554.1 GI:15824047 57 | DBSOURCE accession AB072353.1 58 | KEYWORDS . 59 | SOURCE Aldabra giant tortoise. 60 | ORGANISM Aldabrachelys elephantina 61 | Eukaryota; Metazoa; Chordata; Craniata; Vertebrata; Euteleostomi; 62 | Testudines; Cryptodira; Testudinoidea; Testudinidae; Aldabrachelys. 63 | REFERENCE 1 64 | AUTHORS Shishikura,F. 65 | TITLE The primary structure of hemoglobin D from the Aldabra giant 66 | tortoise, Geochelone gigantea 67 | JOURNAL Zoolog. Sci. 19, 197-206 (2002) 68 | REFERENCE 2 (residues 1 to 141) 69 | AUTHORS Shishikura,F. 70 | TITLE Direct Submission 71 | JOURNAL Submitted (29-SEP-2001) Fumio Shishikura, Nihon University School 72 | of Medicine, Biology; Oyaguchi-kamimachi, 30-1, Itabashi-ku, Tokyo 73 | 173-8610, Japan (E-mail:fshishi@med.nihon-u.ac.jp, 74 | Tel:81-3-3972-8111(ex.2291), Fax:81-3-3972-0027) 75 | FEATURES Location/Qualifiers 76 | source 1..141 77 | /organism="Aldabrachelys elephantina" 78 | /db_xref="taxon:167804" 79 | /note="synonym:Dipsochelys dussumieri~synonym:Geochelone 80 | gigantea" 81 | Protein 1..141 82 | /product="alpha D-globin" 83 | CDS 1..141 84 | /coded_by="join(AB072353.1:1..92,AB072353.1:307..511, 85 | AB072353.1:739..>864)" 86 | /note="hemoglobin D" 87 | ORIGIN 88 | 1 mlteddkqli qhvwekvleh qedfgaeale rmfivypstk tyfphfdlhh dseqirhhgk 89 | 61 kvvgalgdav khidnlsatl selsnlhayn lrvdpvnfkl lshcfqvvlg ahlgreytpq 90 | 121 vqvaydkfla avsavlaeky r 91 | // 92 | -------------------------------------------------------------------------------- /t/data/test.fasta: -------------------------------------------------------------------------------- 1 | >roa1_drome Rea guano receptor type III >> 0.1 2 | MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGLDYRTTDENLKAHEKWGNIVDVV 3 | VMKDPRTKRSRGFGFITYSHSSMIDEAQKSRPHKIDGRVEPKRAVPRQDIDSPNAGATVK 4 | KLFVGALKDDHDEQSIRDYFQHFGNIVDNIVIDKETGKKRGFAFVEFDDYDPVDKVVLQK 5 | QHQLNGKMVDVKKALPKNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGNQNGGGNWNNGGN 6 | NWGNNRGNDNWGNNSFGGGGGGGGGYGGGNNSWGNNNPWDNGNGGGNFGGGGNNWNGGND 7 | FGGYQQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGNYGNNQGFNNGGNNRRY 8 | >roa2_drome Rea guano ligand 9 | MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGLDYRTTDENLKAHEKWGNIVDVV 10 | VMKDPTSTSTSTSTSTSTSTSTMIDEAQKSRPHKIDGRVEPKRAVPRQDIDSPNAGATVK 11 | KLFVGALKDDHDEQSIRDYFQHLLLLLLLDLLLLDLLLLDLLLFVEFDDYDPVDKVVLQK 12 | QHQLNGKMVDVKKALPKNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGNQNGGGNWNNGGN 13 | NWGNNRGNDNWGNNSFGGGGGGGGGYGGGNNSWGNNNPWDNGNGGGNFGGGGNNWNGGND 14 | FGGYQQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGNYGNNQGFNNGGNNRRY 15 | -------------------------------------------------------------------------------- /t/lib/MyTest/PluginDir/Plugin1.pm6: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cjfields/bioperl6/dcf2c56f7871820b767ec274c5c7f8a7347d1d01/t/lib/MyTest/PluginDir/Plugin1.pm6 -------------------------------------------------------------------------------- /t/lib/MyTest/PluginDir/Plugin2.pm6: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cjfields/bioperl6/dcf2c56f7871820b767ec274c5c7f8a7347d1d01/t/lib/MyTest/PluginDir/Plugin2.pm6 --------------------------------------------------------------------------------