annotate gfapts/inc/perlmod/ngsutil.pm @ 1:028f435b6cfb draft default tip

Uploaded
author rdaveau
date Fri, 03 Aug 2012 05:50:41 -0400
parents f753b30013e6
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
1 package ngsutil;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
2 use Exporter;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
3 our @ISA = qw[ Exporter ];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
4 our @EXPORT = qw[ &explode_varcall &varscan ];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
5 use strict;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
6 use warnings FATAL => qw[ numeric uninitialized ];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
7 use List::Util qw[ sum ];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
8
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
9 sub explode_varcall{
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
10 my $N=0;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
11 $_=shift @_ foreach my($POS, $REF, $ALT);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
12 $_=$POS foreach my($START, $END);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
13 my(@length, @range, @idx, @VAR, @POS);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
14 @{$_}=() foreach (\@length, \@range, \@idx, \@VAR, \@POS);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
15 push @length, length($_) foreach ($REF, $ALT);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
16 @range=sort{ $a<=>$b } @length;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
17 if($range[0]==1){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
18 if($range[1]!=1){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
19 foreach ($REF, $ALT){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
20 $_=substr($_, 1);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
21 $_=~s/^$/-/;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
22 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
23 if($length[0]!=1){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
24 $END+=$length[0]-1;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
25 $START++;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
26 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
27 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
28 push @POS, $START, $END;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
29 push @VAR, $REF, $ALT;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
30 }else{
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
31 my @N=();
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
32 undef $_ foreach my ($i, $VAR);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
33 $_-=2 foreach (@length, @range);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
34 $_++ foreach ($START, $END);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
35 $_=substr($_, 1) foreach ($REF, $ALT);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
36 my $indel='-' x ($range[1]-$range[0]);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
37 $VAR.=($_>$range[0])?
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
38 ('-'):((substr($REF, $_, 1) ne substr($ALT, $_, 1))?
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
39 0:1) for 0 .. $range[1];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
40 $N++ while $VAR =~ /0/g;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
41 if($length[0]<$length[1]){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
42 @VAR=($VAR);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
43 @N=($N);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
44 $N=0;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
45 undef($VAR);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
46 $VAR.=($_>$range[0])?
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
47 ('-'):((substr($REF, $length[0]-$_, 1) ne substr($ALT, $length[1]-$_, 1))?
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
48 0:1) for reverse 0 .. $range[1];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
49 $N++ while $VAR =~ /0/g;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
50 if($N>=$N[0]){ $N=shift(@N); $VAR=shift(@VAR); }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
51 else{ $REF=$indel . $REF; }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
52 }else{ $ALT.=$indel; }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
53 foreach (qw[ 0 \- ]){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
54 push @idx, [ $-[0], $+[0]-$-[0] ] while ($VAR =~ /$_+/g);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
55 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
56 @{$_}=() foreach (\@VAR, \@POS);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
57 foreach my $k (@idx){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
58 push @VAR, substr($_, ${$k}[0], ${$k}[1]) || '-' foreach ($REF, $ALT);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
59 push @POS, ${$k}[0], sum(@{$k})-1;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
60 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
61 $_+=$START foreach @POS;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
62 $_=~s/\-+/\-/ foreach @VAR;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
63 for($i=0; $i<$#POS; $i+=2){ $POS[$i+1]=$POS[$i] if $VAR[$i] eq '-'; }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
64 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
65 return(\@POS, \@VAR);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
66 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
67
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
68 sub varscan{
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
69 $_=shift @_ foreach my($kname, $fpath, $href);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
70 my($k, @buffer);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
71 open IN, "<$fpath" or die $!;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
72 while(<IN>){
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
73 next if /^#/;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
74 chomp;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
75 @buffer=split /\s+/, $_;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
76 next if !exists $$href{($k=join(':', @buffer[0..2]))};
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
77 next if $$href{$k}->{ref} !~ $buffer[3];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
78 next if $$href{$k}->{alt} !~ $buffer[4];
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
79 splice(@buffer, 0, 5);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
80 $$href{$k}->{$kname}=join(':', @buffer);
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
81 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
82 close IN;
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
83 }
f753b30013e6 Uploaded
rdaveau
parents:
diff changeset
84 1;