← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to t/HtSNP.t

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

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