bcftools/vcfutils.pl

   1 #!/usr/bin/perl -w
   2
   3 # Author: lh3
   4
   5 use strict;
   6 use warnings;
   7 use Getopt::Std;
   8
   9 &main;
  10 exit;
  11
  12 sub main {
  13   my $version = '0.1.0';
  14   &usage if (@ARGV < 1);
  15   my $command = shift(@ARGV);
  16   my %func = (subsam=>\&subsam, listsam=>\&listsam, fillac=>\&fillac, qstats=>\&qstats, varFilter=>\&varFilter);
  17   die("Unknown command \"$command\".\n") if (!defined($func{$command}));
  18   &{$func{$command}};
  19 }
  20
  21 sub subsam {
  22   die(qq/Usage: vcfutils.pl subsam <in.vcf> [samples]\n/) if (@ARGV == 0);
  23   my ($fh, %h);
  24   my $fn = shift(@ARGV);
  25   my @col;
  26   open($fh, ($fn =~ /\.gz$/)? "gzip -dc $fn |" : $fn) || die;
  27   $h{$_} = 1 for (@ARGV);
  28   while (<$fh>) {
  29         if (/^##/) {
  30           print;
  31         } elsif (/^#/) {
  32           my @t = split;
  33           my @s = @t[0..8]; # all fixed fields + FORMAT
  34           for (9 .. $#t) {
  35                 if ($h{$t[$_]}) {
  36                   push(@s, $t[$_]);
  37                   push(@col, $_);
  38                 }
  39           }
  40           pop(@s) if (@s == 9); # no sample selected; remove the FORMAT field
  41           print join("\t", @s), "\n";
  42         } else {
  43           my @t = split;
  44           if (@col == 0) {
  45                 print join("\t", @t[0..7]), "\n";
  46           } else {
  47                 print join("\t", @t[0..8], map {$t[$_]} @col), "\n";
  48           }
  49         }
  50   }
  51   close($fh);
  52 }
  53
  54 sub listsam {
  55   die(qq/Usage: vcfutils.pl listsam <in.vcf>\n/) if (@ARGV == 0 && -t STDIN);
  56   while (<>) {
  57         if (/^#/ && !/^##/) {
  58           my @t = split;
  59           print join("\n", @t[9..$#t]), "\n";
  60           exit;
  61         }
  62   }
  63 }
  64
  65 sub fillac {
  66   die(qq/Usage: vcfutils.pl fillac <in.vcf>\n\nNote: The GT field MUST BE present and always appear as the first field.\n/) if (@ARGV == 0 && -t STDIN);
  67   while (<>) {
  68         if (/^#/) {
  69           print;
  70         } else {
  71           my @t = split;
  72           my @c;
  73           my $n = 0;
  74           $c[1] = 0;
  75           for (9 .. $#t) {
  76                 if ($t[$_] =~ /^(\d+).(\d+)/) {
  77                   ++$c[$1]; ++$c[$2];
  78                   $n += 2;
  79                 }
  80           }
  81           my $AC = "AC=" . join("\t", @c[1..$#c]) . ";AN=$n";
  82           my $info = $t[7];
  83           $info =~ s/(;?)AC=(\d+)//;
  84           $info =~ s/(;?)AN=(\d+)//;
  85           if ($info eq '.') {
  86                 $info = $AC;
  87           } else {
  88                 $info .= ";$AC";
  89           }
  90           $t[7] = $info;
  91           print join("\t", @t), "\n";
  92         }
  93   }
  94 }
  95
  96 sub qstats {
  97   my %opts = (r=>'', s=>0.01);
  98   getopts('r:s:', \%opts);
  99   die("Usage: vcfutils.pl qstats [-r ref.vcf] <in.vcf>\n
 100 Note: This command discards indels. Output: QUAL #non-indel #SNPs #transitions #joint ts/tv #joint/#ref #joint/#non-indel \n") if (@ARGV == 0 && -t STDIN);
 101   my %ts = (AG=>1, GA=>1, CT=>1, TC=>1);
 102   my %h = ();
 103   if ($opts{r}) { # read the reference positions
 104         my $fh;
 105         open($fh, $opts{r}) || die;
 106         while (<$fh>) {
 107           next if (/^#/);
 108           $h{$1,$2} = 1 if (/^(\S+)\s+(\d+)/);
 109         }
 110         close($fh);
 111   }
 112   my $hsize = scalar(keys %h);
 113   my @a;
 114   while (<>) {
 115         next if (/^#/);
 116         my @t = split;
 117         next if (length($t[3]) != 1 || uc($t[3]) eq 'N');
 118         $t[3] = uc($t[3]); $t[4] = uc($t[4]);
 119         my @s = split(',', $t[4]);
 120         $t[5] = 3 if ($t[5] < 0);
 121         next if (length($s[0]) != 1);
 122         push(@a, [$t[5], ($t[4] eq '.' || $t[4] eq $t[3])? 0 : 1, $ts{$t[3].$s[0]}? 1 : 0, $h{$t[0],$t[1]}? 1 : 0]);
 123   }
 124   push(@a, [-1, 0, 0, 0]); # end marker
 125   die("[qstats] No SNP data!\n") if (@a == 0);
 126   @a = sort {$b->[0]<=>$a->[0]} @a;
 127   my $next = $opts{s};
 128   my $last = $a[0];
 129   my @c = (0, 0, 0, 0);
 130   for my $p (@a) {
 131         if ($p->[0] == -1 || ($p->[0] != $last && $c[0]/@a > $next)) {
 132           my @x;
 133           $x[0] = sprintf("%.3f", $c[1]-$c[2]? $c[2] / ($c[1] - $c[2]) : 100);
 134           $x[1] = sprintf("%.3f", $hsize? $c[3] / $hsize : 0);
 135           $x[2] = sprintf("%.3f", $c[3] / $c[1]);
 136           print join("\t", $last, @c, @x), "\n";
 137           $next = $c[0]/@a + $opts{s};
 138         }
 139         ++$c[0]; $c[1] += $p->[1]; $c[2] += $p->[2]; $c[3] += $p->[3];
 140         $last = $p->[0];
 141   }
 142 }
 143
 144 sub varFilter {
 145   my %opts = (d=>1, D=>10000, l=>30, Q=>25, q=>10, G=>25, s=>100, w=>10, W=>10, N=>2, p=>undef, F=>.001);
 146   getopts('pq:d:D:l:Q:w:W:N:G:F:', \%opts);
 147   die(qq/
 148 Usage:   vcfutils.pl varFilter [options] <in.vcf>
 149
 150 Options: -Q INT    minimum RMS mapping quality for SNPs [$opts{Q}]
 151          -q INT    minimum RMS mapping quality for gaps [$opts{q}]
 152          -d INT    minimum read depth [$opts{d}]
 153          -D INT    maximum read depth [$opts{D}]
 154
 155          -G INT    min indel score for nearby SNP filtering [$opts{G}]
 156          -w INT    SNP within INT bp around a gap to be filtered [$opts{w}]
 157
 158          -W INT    window size for filtering dense SNPs [$opts{W}]
 159          -N INT    max number of SNPs in a window [$opts{N}]
 160
 161          -l INT    window size for filtering adjacent gaps [$opts{l}]
 162
 163          -p        print filtered variants
 164 \n/) if (@ARGV == 0 && -t STDIN);
 165
 166   # calculate the window size
 167   my ($ol, $ow, $oW) = ($opts{l}, $opts{w}, $opts{W});
 168   my $max_dist = $ol > $ow? $ol : $ow;
 169   $max_dist = $oW if ($max_dist < $oW);
 170   # the core loop
 171   my @staging; # (indel_filtering_score, flt_tag)
 172   while (<>) {
 173         my @t = split;
 174         next if (/^#/);
 175         next if ($t[4] eq '.'); # skip non-var sites
 176         my $is_snp = 1;
 177         if (length($t[3]) > 1) {
 178           $is_snp = 0;
 179         } else {
 180           my @s = split(',', $t[4]);
 181           for (@s) {
 182                 $is_snp = 0 if (length > 1);
 183           }
 184         }
 185         # clear the out-of-range elements
 186         while (@staging) {
 187       # Still on the same chromosome and the first element's window still affects this position?
 188           last if ($staging[0][3] eq $t[0] && $staging[0][4] + $staging[0][2] + $max_dist >= $t[1]);
 189           varFilter_aux(shift(@staging), $opts{p}); # calling a function is a bit slower, not much
 190         }
 191         my ($flt, $score) = (0, -1);
 192
 193         # collect key annotations
 194         my ($dp, $mq, $af) = (-1, -1, 1);
 195         if ($t[7] =~ /DP=(\d+)/i) {
 196           $dp = $1;
 197         } elsif ($t[7] =~ /DP4=(\d+),(\d+),(\d+),(\d+)/i) {
 198           $dp = $1 + $2 + $3 + $4;
 199         }
 200         if ($t[7] =~ /MQ=(\d+)/i) {
 201           $mq = $1;
 202         }
 203         if ($t[7] =~ /AF=([^\s;=]+)/i) {
 204           $af = $1;
 205         } elsif ($t[7] =~ /AF1=([^\s;=]+)/i) {
 206           $af = $1;
 207         }
 208         # the depth filter
 209         if ($dp >= 0) {
 210           if ($dp < $opts{d}) {
 211                 $flt = 2;
 212           } elsif ($dp > $opts{D}) {
 213                 $flt = 3;
 214           }
 215         }
 216
 217         # site dependent filters
 218         my $dlen = 0;
 219         if ($flt == 0) {
 220           if (!$is_snp) { # an indel
 221         # If deletion, remember the length of the deletion
 222                 $dlen = length($t[3]) - 1;
 223                 $flt = 1 if ($mq < $opts{q});
 224                 # filtering SNPs
 225                 if ($t[5] >= $opts{G}) {
 226                   for my $x (@staging) {
 227             # Is it a SNP and is it outside the SNP filter window?
 228                         next if ($x->[0] >= 0 || $x->[4] + $x->[2] + $ow < $t[1]);
 229                         $x->[1] = 5 if ($x->[1] == 0);
 230                   }
 231                 }
 232                 # the indel filtering score
 233                 $score = $t[5];
 234                 # check the staging list for indel filtering
 235                 for my $x (@staging) {
 236           # Is it a SNP and is it outside the gap filter window
 237                   next if ($x->[0] < 0 || $x->[4] + $x->[2] + $ol < $t[1]);
 238                   if ($x->[0] < $score) {
 239                         $x->[1] = 6;
 240                   } else {
 241                         $flt = 6; last;
 242                   }
 243                 }
 244           } else { # a SNP
 245                 $flt = 1 if ($mq < $opts{Q});
 246                 # check adjacent SNPs
 247                 my $k = 1;
 248                 for my $x (@staging) {
 249                   ++$k if ($x->[0] < 0 && -($x->[0] + 1) > $opts{F} && $x->[4] + $x->[2] + $oW >= $t[1] && ($x->[1] == 0 || $x->[1] == 4 || $x->[1] == 5));
 250                 }
 251                 # filtering is necessary
 252                 if ($k > $opts{N}) {
 253                   $flt = 4;
 254                   for my $x (@staging) {
 255                          $x->[1] = 4 if ($x->[0] < 0 && $x->[4] + $x->[2] + $oW >= $t[1] && $x->[1] == 0);
 256                   }
 257                 } else { # then check gap filter
 258                   for my $x (@staging) {
 259                         next if ($x->[0] < 0 || $x->[4] + $x->[2] + $ow < $t[1]);
 260                         if ($x->[0] >= $opts{G}) {
 261                           $flt = 5; last;
 262                         }
 263                   }
 264                 }
 265           }
 266         }
 267         push(@staging, [$score < 0? -$af-1 : $score, $flt, $dlen, @t]);
 268   }
 269   # output the last few elements in the staging list
 270   while (@staging) {
 271         varFilter_aux(shift @staging, $opts{p});
 272   }
 273 }
 274
 275 sub varFilter_aux {
 276   my ($first, $is_print) = @_;
 277   if ($first->[1] == 0) {
 278         print join("\t", @$first[3 .. @$first-1]), "\n";
 279   } elsif ($is_print) {
 280         print STDERR join("\t", substr("UQdDWGgsiX", $first->[1], 1), @$first[3 .. @$first-1]), "\n";
 281   }
 282 }
 283
 284 sub usage {
 285   die(qq/
 286 Usage:   vcfutils.pl <command> [<arguments>]\n
 287 Command: subsam       get a subset of samples
 288          listsam      list the samples
 289          fillac       fill the allele count field
 290          qstats       SNP stats stratified by QUAL
 291          varFilter    filtering short variants
 292 \n/);
 293 }