branch-1-6/t/PopGen/HtSNP.t

   1 # -*-Perl-*- Test Harness script for Bioperl
   2 # $Id$
   3
   4 use strict;
   5
   6 BEGIN {
   7     use lib '.';
   8     use Bio::Root::Test;
   9
  10     test_begin(-tests => 8);
  11
  12     use_ok('Bio::PopGen::HtSNP');
  13 }
  14
  15 my $hap = [
  16      'acgt?cact',
  17      'acgt?ca-t',
  18      'cg?tag?gc',
  19      'cactcgtgc',
  20      'cgctcgtgc',
  21      'cggtag?gc',
  22      'ac?t?cact',
  23      ];
  24
  25 my $snp = [qw/s1 s2 s3 s4 s5 s6 s7 s8 s9/];
  26
  27 my $pop = [
  28      [qw/ uno    0.20/],
  29      [qw/ dos    0.20/],
  30      [qw/ tres   0.15/],
  31      [qw/ cuatro 0.15/],
  32      [qw/ cinco  0.10/],
  33      [qw/ seis   0.10/],
  34      [qw/ siete  0.10/],
  35        ];
  36
  37 my $obj = Bio::PopGen::HtSNP->new(-haplotype_block => $hap,
  38                                    -snp_ids         => $snp,
  39                                    -pattern_freq    => $pop,
  40 );
  41
  42
  43 # check lenght of the haplotype
  44 is($obj->hap_length,9); # length of the haplotype must be 9
  45
  46 # check silent SNPs
  47 is( (join ' ', @{$obj->silent_snp}) ,'s4'); # the silent snp is in position 4 (counting from 1)
  48
  49 # check degenerated SNPs
  50 is( (join ' ', @{$obj->deg_snp}) ,'s7 s5 s3'); # degenerate SNPs
  51
  52 # check useful SNP's
  53 is( (join ' ', @{$obj->useful_snp}) ,'s1 s2 s6 s8 s9'); # degenerate SNPs
  54
  55 # check the SNP code
  56 is( (join ' ',@{$obj->snp_type_code}),'36 63 36 75 36'); # code for SNPs
  57
  58 # check the HtType
  59 is( (join ' ',@{$obj->ht_type}),'36 63 75'); # min snp_code
  60
  61 my $tmp = $obj->deg_pattern();
  62 my $err=0;
  63
  64 foreach my $family (keys %$tmp){
  65     if ($family eq '0'){
  66        unless ( (join ' ', @{$tmp->{$family}}) eq '0 6'){
  67            $err=1;
  68        }
  69     }
  70     if ($family eq '1'){
  71        unless ( (join ' ', @{$tmp->{$family}}) eq '1'){
  72            $err=1;
  73        }
  74     }
  75     if ($family eq '2'){
  76        unless ( (join ' ', @{$tmp->{$family}}) eq '2 4 5'){
  77            $err=1;
  78        }
  79     }
  80     if ($family eq '3'){
  81        unless ( (join ' ', @{$tmp->{$family}}) eq '3'){
  82            $err=1;
  83        }
  84     }
  85 }
  86
  87 ok(! $err); # clustering degenerated haplotypes