t/primaryqual.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 => 35);
  11
  12     use_ok('Bio::SeqIO');
  13     use_ok('Bio::Seq::Quality');
  14     use_ok('Bio::Seq::PrimaryQual');
  15 }
  16
  17 my $DEBUG = test_debug();
  18 my $verbose = -1 unless $DEBUG;
  19
  20 # redirect STDERR to STDOUT
  21 open (STDERR, ">&STDOUT");
  22
  23 my $string_quals = "10 20 30 40 50 40 30 20 10";
  24 print("Quals are $string_quals\n") if($DEBUG);
  25 my $qualobj = Bio::Seq::PrimaryQual->new(
  26                                           '-qual' => $string_quals,
  27                                           '-id'  => 'QualityFragment-12',
  28                                           '-accession_number' => 'X78121',
  29                                           );
  30 ok($qualobj);
  31 is($qualobj->display_id, 'QualityFragment-12');
  32 is($qualobj->accession_number, 'X78121');
  33
  34 my @q2 = split/ /,$string_quals;
  35 $qualobj = Bio::Seq::PrimaryQual->new
  36     ( '-qual'             => \@q2,
  37       '-primary_id'          => 'chads primary_id',
  38       '-desc'                   => 'chads desc',
  39       '-accession_number' => 'chads accession_number',
  40       '-id'                        => 'chads id',
  41                 '-header'           => 'chads header'
  42       );
  43
  44 is($qualobj->primary_id, 'chads primary_id');
  45 my $rqual = $qualobj->qual();
  46 is(ref($rqual),"ARRAY");
  47
  48 my $newqualstring = "50 90 1000 20 12 0 0";
  49
  50 $qualobj->qual($newqualstring);
  51 my $retrieved_quality = $qualobj->qual();
  52 my $retrieved_quality_string = join(' ', @$retrieved_quality);
  53 is($retrieved_quality_string,$newqualstring);
  54
  55 my @newqualarray = split/ /,$newqualstring;
  56 $qualobj->qual(\@newqualarray);
  57 $retrieved_quality = $qualobj->qual();
  58 $retrieved_quality_string = join(' ',@$retrieved_quality);
  59 is($retrieved_quality_string,$newqualstring);
  60
  61 eval {
  62     $qualobj->qual("chad");
  63 };
  64 like($@, qr/not look healthy/);
  65
  66 eval { $qualobj->qual(""); };
  67 ok(!$@);
  68
  69 eval { $qualobj->qual(" 4"); };
  70 ok(!$@);
  71
  72 $qualobj->qual("4 10");
  73
  74 is($qualobj->length(),2 );
  75
  76 $qualobj->qual("10 20 30 40 50 40 30 20 10");
  77 my @subquals = @{$qualobj->subqual(3,6);};
  78 is(@subquals, 4);
  79      # chad, note to self, evaluate border conditions
  80 is ("30 20 10", join(' ',@{$qualobj->subqual(7,9)}));
  81
  82
  83 my @false_comparator = qw(30 40 70 40);
  84 my @true_comparator = qw(30 40 50 40);
  85 ok(!&compare_arrays(\@subquals,\@true_comparator));
  86
  87 eval { $qualobj->subqual(-1,6); };
  88 like($@, qr/EX/ );
  89 eval { $qualobj->subqual(1,6); };
  90 ok(!$@);
  91 eval { $qualobj->subqual(1,9); };
  92 ok(!$@);
  93 eval { $qualobj->subqual(9,1); };
  94 like($@, qr/EX/ );
  95
  96
  97 is($qualobj->display_id(), "chads id");
  98 $qualobj->display_id("chads new display_id");
  99 is($qualobj->display_id(), "chads new display_id");
 100
 101 is($qualobj->accession_number(), "chads accession_number");
 102 $qualobj->accession_number("chads new accession_number");
 103 is($qualobj->accession_number(), "chads new accession_number");
 104 is($qualobj->primary_id(), "chads primary_id");
 105 $qualobj->primary_id("chads new primary_id");
 106 is($qualobj->primary_id(), "chads new primary_id");
 107
 108 is($qualobj->desc(), "chads desc");
 109 $qualobj->desc("chads new desc");
 110 is($qualobj->desc(), "chads new desc");
 111 is($qualobj->display_id(), "chads new display_id");
 112 $qualobj->display_id("chads new id");
 113 is($qualobj->display_id(), "chads new id");
 114
 115 is($qualobj->header(), "chads header");
 116
 117 my $in_qual  = Bio::SeqIO->new(-file => test_input_file('qualfile.qual') ,
 118                                '-format' => 'qual',
 119                                '-verbose' => $verbose);
 120 ok($in_qual);
 121 my $pq = $in_qual->next_seq();
 122 is($pq->qual()->[99], '39'); # spot check boundary
 123 is($pq->qual()->[100], '39'); # spot check boundary
 124
 125 my $out_qual = Bio::SeqIO->new('-file'    => ">".test_output_file(),
 126                                '-format'  => 'qual',
 127                                '-verbose' => $verbose);
 128 $out_qual->write_seq(-source    =>      $pq);
 129
 130 my $swq545 = Bio::Seq::Quality->new (   -seq    =>      "ATA",
 131                                         -qual   =>      $pq
 132                                     );
 133 $out_qual->write_seq(-source    =>      $swq545);
 134
 135 $in_qual = Bio::SeqIO->new('-file' => test_input_file('qualfile.qual') ,
 136                            '-format' => 'qual',
 137                            '-verbose' => $verbose);
 138
 139 my $out_qual2 = Bio::SeqIO->new('-file' => ">".test_output_file(),
 140                                 '-format'  => 'qual',
 141                                 '-verbose' => $verbose);
 142
 143 while ( my $batch_qual = $in_qual->next_seq() ) {
 144         $out_qual2->write_seq(-source   =>      $batch_qual);
 145 }
 146
 147 sub display {
 148     if($DEBUG ) {
 149         my @quals;
 150         print("I saw these in qualfile.qual:\n") ;
 151         while ( my $qual = $in_qual->next_seq() ) {
 152             # ::dumpValue($qual);
 153             print($qual->display_id()."\n");
 154             @quals = @{$qual->qual()};
 155             print("(".scalar(@quals).") quality values.\n");
 156         }
 157     }
 158 }
 159
 160 # dumpValue($qualobj);
 161
 162 sub compare_arrays {
 163         my ($a1,$a2) = @_;
 164         return 1 if (scalar(@{$a1}) != scalar(@{$a2}));
 165         my ($v1,$v2,$diff,$curr);
 166         for ($curr=0;$curr<scalar(@{$a1});$curr++){
 167                 return 1 if ($a1->[$curr] ne $a2->[$curr]);
 168         }
 169         return 0;
 170 }