t/PrimarySeq.t

   1 # -*-Perl-*- Test Harness script for Bioperl
   2 # $Id$
   3
   4 use strict;
   5
   6 BEGIN {
   7         use lib 't/lib';
   8     use BioperlTest;
   9
  10     test_begin(-tests => 53);
  11
  12     use_ok('Bio::PrimarySeq');
  13     use_ok('Bio::Location::Simple');
  14     use_ok('Bio::Location::Fuzzy');
  15     use_ok('Bio::Location::Split');
  16 }
  17
  18 my $seq = Bio::PrimarySeq->new(
  19                                          '-seq'            => 'TTGGTGGCGTCAACT',
  20                                '-display_id'       => 'new-id',
  21                                '-alphabet'         => 'dna',
  22                                '-accession_number' => 'X677667',
  23                                '-desc'             => 'Sample Bio::Seq object');
  24 ok defined $seq;
  25 isa_ok $seq,'Bio::PrimarySeqI';
  26 is $seq->accession_number(), 'X677667';
  27 is $seq->seq(), 'TTGGTGGCGTCAACT';
  28 is $seq->display_id(), 'new-id';
  29 is $seq->alphabet(), 'dna';
  30 is $seq->is_circular(), undef;
  31 ok $seq->is_circular(1);
  32 is $seq->is_circular(0), 0;
  33
  34 # check IdentifiableI and DescribableI interfaces
  35 isa_ok $seq,'Bio::IdentifiableI';
  36 isa_ok $seq,'Bio::DescribableI';
  37 # make sure all methods are implemented
  38 is $seq->authority("bioperl.org"), "bioperl.org";
  39 is $seq->namespace("t"), "t";
  40 is $seq->version(0), 0;
  41 is $seq->lsid_string(), "bioperl.org:t:X677667";
  42 is $seq->namespace_string(), "t:X677667.0";
  43 is $seq->description(), 'Sample Bio::Seq object';
  44 is $seq->display_name(), "new-id";
  45
  46 my $location = Bio::Location::Simple->new('-start' => 2,
  47                                                                                                           '-end' => 5,
  48                                                                                                           '-strand' => -1);
  49 is ($seq->subseq($location), 'ACCA');
  50
  51 my $splitlocation = Bio::Location::Split->new();
  52 $splitlocation->add_sub_Location( Bio::Location::Simple->new(
  53                                                                  '-start' => 1,
  54                                                             '-end'   => 4,
  55                                                             '-strand' => 1));
  56
  57 $splitlocation->add_sub_Location( Bio::Location::Simple->new(
  58                          '-start' => 7,
  59                                                             '-end'   => 12,
  60                                                             '-strand' => -1));
  61
  62 is( $seq->subseq($splitlocation), 'TTGGTGACGC');
  63
  64 my $fuzzy = Bio::Location::Fuzzy->new(-start => '<3',
  65                                                                                                  -end   => '8',
  66                                                                                                  -strand => 1);
  67
  68 is( $seq->subseq($fuzzy), 'GGTGGC');
  69
  70 my $trunc = $seq->trunc(1,4);
  71 isa_ok $trunc, 'Bio::PrimarySeqI';
  72 is $trunc->seq(), 'TTGG' or diag("Expecting TTGG. Got ".$trunc->seq());
  73
  74 $trunc = $seq->trunc($splitlocation);
  75 isa_ok($trunc, 'Bio::PrimarySeqI');
  76 is( $trunc->seq(), 'TTGGTGACGC');
  77
  78 $trunc = $seq->trunc($fuzzy);
  79 isa_ok($trunc, 'Bio::PrimarySeqI');
  80 is( $trunc->seq(), 'GGTGGC');
  81
  82 my $rev = $seq->revcom();
  83 isa_ok($rev, 'Bio::PrimarySeqI');
  84
  85 is $rev->seq(), 'AGTTGACGCCACCAA' or diag('revcom() failed, was ' . $rev->seq());
  86
  87 #
  88 # Translate
  89 #
  90
  91 my $aa = $seq->translate(); # TTG GTG GCG TCA ACT
  92 is $aa->seq, 'LVAST', "Translation: ". $aa->seq;
  93
  94 # tests for non-standard initiator codon coding for
  95 # M by making translate() look for an initiator codon and
  96 # terminator codon ("complete", the 5th argument below)
  97 $seq->seq('TTGGTGGCGTCAACTTAA'); # TTG GTG GCG TCA ACT TAA
  98 $aa = $seq->translate(undef, undef, undef, undef, 1);
  99 is $aa->seq, 'MVAST', "Translation: ". $aa->seq;
 100
 101 # same test as previous, but using named parameter
 102 $aa = $seq->translate(-complete => 1);
 103 is $aa->seq, 'MVAST', "Translation: ". $aa->seq;
 104
 105 # find ORF, ignore codons outside the ORF or CDS
 106 $seq->seq('TTTTATGGTGGCGTCAACTTAATTT'); # ATG GTG GCG TCA ACT
 107 $aa = $seq->translate(-orf => 1);
 108 is $aa->seq, 'MVAST*', "Translation: ". $aa->seq;
 109
 110 # smallest possible ORF
 111 $seq->seq("ggggggatgtagcccc"); # atg tga
 112 $aa = $seq->translate(-orf => 1);
 113 is $aa->seq, 'M*', "Translation: ". $aa->seq;
 114
 115 # same as previous but complete, so * is removed
 116 $aa = $seq->translate(-orf => 1,
 117                       -complete => 1);
 118 is $aa->seq, 'M', "Translation: ". $aa->seq;
 119
 120 # ORF without termination codon
 121 # should warn, let's change it into throw for testing
 122 $seq->verbose(2);
 123 $seq->seq("ggggggatgtggcccc"); # atg tgg ccc
 124 eval { $seq->translate(-orf => 1); };
 125 if ($@) {
 126     like( $@, qr/atgtggcccc\n/);
 127         $seq->verbose(-1);
 128         $aa = $seq->translate(-orf => 1);
 129     is $aa->seq, 'MWP', "Translation: ". $aa->seq;
 130 }
 131 $seq->verbose(0);
 132
 133 # use non-standard codon table where terminator is read as Q
 134 $seq->seq('ATGGTGGCGTCAACTTAG'); # ATG GTG GCG TCA ACT TAG
 135 $aa = $seq->translate(-codontable_id => 6);
 136 is $aa->seq, 'MVASTQ' or diag("Translation: ". $aa->seq);
 137
 138 # insert an odd character instead of terminating with *
 139 $aa = $seq->translate(-terminator => 'X');
 140 is $aa->seq, 'MVASTX' or diag("Translation: ". $aa->seq);
 141
 142 # change frame from default
 143 $aa = $seq->translate(-frame => 1); # TGG TGG CGT CAA CTT AG
 144 is $aa->seq, 'WWRQL' or diag("Translation: ". $aa->seq);
 145
 146 $aa = $seq->translate(-frame => 2); # GGT GGC GTC AAC TTA G
 147 is $aa->seq, 'GGVNL' or diag("Translation: ". $aa->seq);
 148
 149 # TTG is initiator in Standard codon table? Afraid so.
 150 $seq->seq("ggggggttgtagcccc"); # ttg tag
 151 $aa = $seq->translate(-orf => 1);
 152 is $aa->seq, 'L*' or diag("Translation: ". $aa->seq);
 153
 154 # Replace L at 1st position with M by setting complete to 1
 155 $seq->seq("ggggggttgtagcccc"); # ttg tag
 156 $aa = $seq->translate(-orf => 1,
 157                                                          -complete => 1);
 158 is $aa->seq, 'M' or diag("Translation: ". $aa->seq);
 159
 160 # Ignore non-ATG initiators (e.g. TTG) in codon table
 161 $seq->seq("ggggggttgatgtagcccc"); # atg tag
 162 $aa = $seq->translate(-orf => 1,
 163                                                          -start => "atg",
 164                                                          -complete => 1);
 165 is $aa->seq, 'M' or diag("Translation: ". $aa->seq);
 166
 167
 168 # test for character '?' in the sequence string
 169 is $seq->seq('TTGGTGGCG?CAACT'), 'TTGGTGGCG?CAACT';
 170
 171 # test for some aliases
 172 $seq = Bio::PrimarySeq->new(-id          => 'aliasid',
 173                                                                          -description => 'Alias desc');
 174 is($seq->description, 'Alias desc');
 175 is($seq->display_id, 'aliasid');
 176
 177 # test that x's are ignored and n's are assumed to be 'dna' no longer true!
 178 # See Bug 2438. There are protein sequences floating about which are all 'X'
 179 # (unknown aa)
 180
 181 $seq->seq('atgxxxxxx');
 182 is($seq->alphabet,'protein');
 183 $seq->seq('atgnnnnnn');
 184 is($seq->alphabet,'dna');