ngs_server 0.1 → 0.2

data/ext/vcftools/perl/vcf-query

@@ -0,0 +1,286 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+my $opts = parse_params();
+read_data($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg ) { confess @msg; }
+    die
+        "Usage: query-vcf [OPTIONS] file.vcf.gz\n",
+        "Options:\n",
+        "   -c, --columns <NA001,NA002,..>      List of comma-separated column names.\n",
+        "   -f, --format <string>               The default is '%CHROM:%POS\\t%REF[\\t%SAMPLE=%GT]\\n'\n",
+        "   -l, --list-columns                  List columns.\n",
+        "   -r, --region chr:from-to            Retrieve the region. (Runs tabix.)\n",
+        "   -h, -?, --help                      This help message.\n",
+        "Examples:\n",
+        "   query-vcf file.vcf.gz 1:1000-2000 -c NA001,NA002,NA003\n",
+        "   query-vcf file.vcf.gz -r 1:1000-2000 -f '%CHROM:%POS\\t%REF\\t%ALT[\\t%SAMPLE:%*=,]\\n'\n",
+        "   query-vcf file.vcf.gz -f '[%GT\\t]%LINE\\n'\n",
+        "   query-vcf file.vcf.gz -f '%CHROM\\t%POS\\t%INFO/DP\\t%FILTER\\n'\n",
+        "\n";
+}
+
+
+sub parse_params
+{
+    my $opts = { columns=>'', format_string=>"%CHROM:%POS\t%REF[\t%SAMPLE=%GT]\n" };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-f' || $arg eq '--format' ) { $$opts{format_string}=shift(@ARGV); next }
+        if ( $arg eq '-c' || $arg eq '--columns' ) { $$opts{columns}=shift(@ARGV); next }
+        if ( $arg eq '-l' || $arg eq '--list-columns' ) { $$opts{list_columns}=1; next }
+        if ( $arg eq '-r' || $arg eq '--region' ) { $$opts{region}=shift(@ARGV); next }
+        if ( -e $arg or $arg=~m{^(?:ftp|http)://} ) { $$opts{file}=$arg; next; }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( !exists($$opts{region}) && exists($$opts{file}) && ($arg=~/^[^:]+:[0-9,]+-[0-9,]+$/ or $arg=~/^[^\:]+$/) ) { $$opts{region}=$arg; next; }
+        error("Unknown parameter or non-existent file \"$arg\". Run -h for help.\n");
+    }
+    if ( !exists($$opts{file}) && exists($$opts{region}) ) { error("The region cannot be used when streaming the file.\n"); }
+    return $opts;
+}
+
+sub parse_format_string
+{
+    my ($str,$hash) = @_;
+    my (@arr,%idx,$join1,$join2);
+    $str =~ s/\\n/\n/g;
+    $str =~ s/\\t/\t/g;
+    while ($str)
+    {
+        if ( !($str=~/%/) )
+        {
+            push @arr,$str;
+            last;
+        }
+
+        my $before = $`;
+        $str = $';
+
+        my $match;
+        if ( $str=~/^[*](.)(.)/ )
+        {
+            $match = '*'; $join1=$1; $join2=$2;
+        }
+        elsif ( $str=~m{([A-Za-z0-9/]+)} )
+        {
+            $match = $1;
+        }
+        else { error("FIXME: $str"); }
+
+        if ( $before ) { push @arr,$before; }
+        push @arr,'.';      # If the tag is not present in the VCF, a missing value ('.') will be printed instead.
+        $idx{$match} = $#arr;
+        $str = $';
+    }
+    $$hash{format} = \@arr;
+    $$hash{idx}    = \%idx;
+    $$hash{join1}  = $join1;
+    $$hash{join2}  = $join2;
+}
+
+sub parse_format
+{
+    my ($opts,$cols) = @_;
+
+    $$opts{before} = {};
+    $$opts{repeat} = {};
+    $$opts{after}  = {};
+
+    my ($before,$repeat,$after);
+
+    my $str = $$opts{format_string};
+    $before = $str;
+
+    if ( $str=~/\[([^\]]+)\]/ )
+    {
+        $before = $`;
+        $repeat = $1;
+        $after  = $';
+    }
+    if ( $before ) { parse_format_string($before,$$opts{before}); }
+    if ( $repeat ) { parse_format_string($repeat,$$opts{repeat}); }
+    if ( $after ) { parse_format_string($after,$$opts{after}); }
+}
+
+sub copy_array
+{
+    my ($arr) = @_;
+    my @out;
+    for my $item (@$arr) { push @out,$item; }
+    return @out;
+}
+
+sub get_columns
+{
+    my ($vcf) = @_;
+    my @cols = ();
+    my $ncols = @{$$vcf{columns}};
+    for (my $i=9; $i<$ncols; $i++)
+    {
+        push @cols, $$vcf{columns}[$i];
+    }
+    return \@cols;
+}
+
+sub list_columns
+{
+    my ($opts) = @_;
+    my $cols = get_columns($$opts{vcf});
+    for my $col (@$cols) { print "$col\n"; }
+}
+
+sub read_data
+{
+    my ($opts) = @_;
+
+    my %args = ( print_header=>1 );
+    if ( $$opts{region} ) { $args{region} = $$opts{region}; }
+    if ( exists($$opts{file}) ) { $args{file} = $$opts{file}; }
+    else { $args{fh} = \*STDIN; }
+
+    my $vcf = Vcf->new(%args);
+    $$opts{vcf} = $vcf;
+    $vcf->parse_header();
+
+    if ( $$opts{list_columns} ) { list_columns($opts); exit; }
+
+    my @cols = split(/,/,$$opts{columns});
+    if ( !@cols ) { @cols = @{get_columns($$opts{vcf})}; }
+    
+
+    # The hash opts will be filled with the keys 'before','repeat','after' with formatting information
+    parse_format($opts);
+
+    while (my $line=$vcf->next_line())
+    {
+        my $x=$vcf->next_data_hash($line);
+        
+        # Fill everything what comes before the repeat []
+        # Code repetition and not very nice, should be changed at some point...
+        if ( $$opts{before} )
+        {
+            my (@out) = copy_array($$opts{before}{format});
+
+            while (my ($colname,$idx) = each %{$$opts{before}{idx}})
+            {
+                if ( $colname eq 'LINE' ) { chomp($line); $out[$idx] = "$line"; next; }
+                if ( $colname eq 'ALT' ) { $out[$idx] = join(',',@{$$x{ALT}}); next; }
+                if ( $colname eq 'FILTER' ) { $out[$idx] = join(';',@{$$x{FILTER}}); next; }
+
+                if ( $colname=~m{INFO/(.+)} ) 
+                {  
+                    if ( exists($$x{INFO}{$1}) && !defined($$x{INFO}{$1}) )
+                    {
+                        # It is a flag
+                        $out[$idx] = 'True';
+                    }
+                    else
+                    {
+                        $out[$idx] = $$x{INFO}{$1};                        
+                    }
+                    next; 
+                }
+                if ( exists($$x{$colname}) ) { $out[$idx] = $$x{$colname}; }
+            }
+            for (my $i=0; $i<@out; $i++) { 
+               if (!defined($out[$i])) { $out[$i]='.'; } 
+               if( 'HASH' eq ref $out[$i] ) {
+                  my $info_str = "{";
+                  while( my ($k, $v) = each %{$out[$i]} ) {
+                     if ($info_str ne "{") {$info_str .= ',';}
+                     $info_str .= '"' . $k . '"' . ":" . '"' . $v . '"';
+                          #print "key: $k, value: $v.\n";
+                  }
+                  $out[$i] = $info_str . "}";
+               }
+            }
+            print join('',@out);
+        }
+
+        # Fill the repeaty stuff (the sample columns)
+        if ( $$opts{repeat} )
+        {
+            for my $col (@cols)
+            {
+                my ($alleles,$seps,$is_phased,$is_empty) = $vcf->parse_haplotype($x,$col);
+                my (@out) = copy_array($$opts{repeat}{format});
+                while (my ($colname,$idx) = each %{$$opts{repeat}{idx}})
+                {
+                    if ( exists($$x{gtypes}{$col}{$colname}) ) { $out[$idx] = $$x{gtypes}{$col}{$colname}; }
+                    elsif ( exists($$x{$colname}) ) { $out[$idx] = $$x{$colname}; }
+                }
+                if ( exists($$opts{repeat}{idx}{SAMPLE}) ) { $out[$$opts{repeat}{idx}{SAMPLE}] = $col; }
+                if ( exists($$opts{repeat}{idx}{GT}) ) 
+                { 
+                    my $tmp = $$alleles[0];
+                    for (my $i=0; $i<@$seps; $i++) { $tmp .= $$seps[$i].$$alleles[$i+1]; }
+                    $out[$$opts{repeat}{idx}{GT}] = $tmp;
+                }
+                if ( exists($$opts{repeat}{idx}{'*'}) )
+                {
+                    my $sep1 = $$opts{repeat}{join1};
+                    my $sep2 = $$opts{repeat}{join2};
+                    my @tmp;
+                    while (my ($key,$value)=each(%{$$x{gtypes}{$col}}))
+                    {
+                        if ( $key eq 'GT' )
+                        { 
+                            $value = $$alleles[0];
+                            for (my $i=0; $i<@$seps; $i++) { $value .= $$seps[$i].$$alleles[$i+1]; }
+                        }
+                        push @tmp, $key.$sep1.$value;
+                    }
+                    my $idx = $$opts{repeat}{idx}{'*'};
+                    $out[$idx] = join($sep2,@tmp);
+                }
+                for (my $i=0; $i<@out; $i++) { if (!defined($out[$i])) { $out[$i]='.'; } }
+                print join('',@out);
+            }
+        }
+
+        # Fill everything what comes after the repeat ([])
+        if ( $$opts{after} )
+        {
+            my (@out) = copy_array($$opts{after}{format});
+            while (my ($colname,$idx) = each %{$$opts{after}{idx}})
+            {
+                if ( $colname eq 'LINE' ) { chomp($line); $out[$idx] = $line; next; }
+                if ( $colname eq 'ALT' ) { $out[$idx] = join(',',@{$$x{ALT}}); next; }
+                if ( $colname eq 'FILTER' ) { $out[$idx] = join(';',@{$$x{FILTER}}); next; }
+                if ( $colname=~m{INFO/(.+)} ) 
+                { 
+                    if ( exists($$x{INFO}{$1}) && !defined($$x{INFO}{$1}) )
+                    {
+                        # It is a flag
+                        $out[$idx] = 'True';
+                    }
+                    else
+                    {
+                        $out[$idx] = $$x{INFO}{$1}; 
+                    }
+                    next; 
+                }
+                if ( exists($$x{$colname}) ) { $out[$idx] = $$x{$colname}; }
+            }
+            for (my $i=0; $i<@out; $i++) { if (!defined($out[$i])) { $out[$i]='.'; } }
+            print join('',@out);
+        }
+    }
+}
+
+

data/ext/vcftools/perl/vcf-shuffle-cols

@@ -0,0 +1,89 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+my $opts = parse_params();
+concat($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "About: Reorder columns to match the order in the template VCF.\n",
+        "Usage: vcf-shuffle-cols [OPTIONS] -t template.vcf.gz file.vcf.gz > out.vcf\n",
+        "Options:\n",
+        "   -t, --template <file>            The file with the correct order of the columns.\n",
+        "   -h, -?, --help                   This help message.\n",
+        "\n";
+}
+
+sub parse_params
+{
+    my $opts = {};
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-t' || $arg eq '--template' ) { $$opts{template}=shift(@ARGV); next; }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( -e $arg ) { $$opts{file}=$arg; next }
+        error("Unknown parameter \"$arg\". Run -h for help.\n");
+    }
+    if ( !exists($$opts{template}) ) { error("Missing the -t option.\n"); }
+    return $opts;
+}
+
+sub concat
+{
+    my ($opts) = @_;
+    my $tmpl = Vcf->new(file=>$$opts{template});
+    $tmpl->parse_header();
+    $tmpl->close();
+
+    my $vcf = $$opts{file} ? Vcf->new(file=>$$opts{file}) : Vcf->new(fh=>\*STDIN);
+    $vcf->parse_header();
+
+    # Check if one-to-one correspondence can be found and create a mapping
+    my @new_to_old = ();
+    for my $tcol (@{$$tmpl{columns}})
+    {
+        if ( !exists($$vcf{has_column}{$tcol}) ) { error("TODO: the column names do not match\n"); }
+    }
+    for my $vcol (@{$$vcf{columns}})
+    {
+        if ( !exists($$tmpl{has_column}{$vcol}) ) { error("TODO: the column names do not match\n"); }
+        my $new = $$tmpl{has_column}{$vcol} - 1;
+        my $old = $$vcf{has_column}{$vcol} - 1;
+        $new_to_old[$new] = $old;
+    }
+
+
+    # Output the header with modified column order
+    my $ncols = @{$$tmpl{columns}} - 1;
+    my @cols  = @{$$tmpl{columns}}[9..$ncols];
+    print $vcf->format_header(\@cols);
+
+    while (my $x=$vcf->next_data_array())
+    {
+        print $$x[0];
+        for (my $i=1; $i<=$ncols; $i++)
+        {
+            my $idx = $new_to_old[$i];
+            print "\t".$$x[$idx];
+        }
+        print "\n";
+    }
+}
+

data/ext/vcftools/perl/vcf-sort

@@ -0,0 +1,79 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+
+my $opts = parse_params();
+sort_vcf($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "Usage: vcf-sort > out.vcf\n",
+        "       cat file.vcf | vcf-sort > out.vcf\n",
+        "Options:\n",
+        "   -h, -?, --help                   This help message.\n",
+        "\n";
+}
+
+sub parse_params
+{
+    my $opts = {};
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( -e $arg ) { $$opts{file}=$arg; next }
+        error("Unknown parameter \"$arg\". Run -h for help.\n");
+    }
+    return $opts;
+}
+
+sub sort_vcf
+{
+    my ($opts) = @_;
+    
+    my $fh;
+    if ( exists($$opts{file}) )
+    {
+        if ( $$opts{file}=~/\.gz$/i )
+        {
+            open($fh,"gunzip -c $$opts{file} |") or error("$$opts{file}: $!");
+        }
+        else
+        {
+            open($fh,'<',$$opts{file}) or error("$$opts{file}: $!");
+        }
+    }
+    else { $fh = *STDIN; }
+
+    my $cmd = 'sort -k 1,1d -k 2,2n';
+    open(my $sort_fh,"| $cmd") or error("$cmd: $!");
+
+    my $unflushed = select(STDOUT); 
+    $| = 1; 
+    while (my $line=<$fh>)
+    {
+        if ( $line=~/^#/ ) { print $line; next; }
+        print $sort_fh $line;
+        last;
+    }
+    select($unflushed);
+    while (my $line=<$fh>)
+    {
+        print $sort_fh $line;
+    }
+}
+

data/ext/vcftools/perl/vcf-stats

@@ -0,0 +1,160 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use VcfStats;
+
+my $opts = parse_params();
+vcf_stats($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "Usage: vcf-stats [OPTIONS] file.vcf.gz\n",
+        "Options:\n",
+        "   -d, --dump <file>                           Take an existing dump file and recreate the files (works with -p)\n",
+        "   -f, --filters <filter1,filter2>             List of filters such as column/field (any value), column/field=bin:max (cluster in bins),column/field=value (exact value)\n",
+        "   -p, --prefix <dir/string>                   Prefix of output files. If slashes are present, directories will be created.\n",
+        "   -s, --samples <list>                        Process only the listed samples, - for none. Excluding unwanted samples may increase performance considerably.\n",
+        "   -h, -?, --help                              This help message.\n",
+        "\n",
+        "Examples:\n",
+        "   # Calculate stats separately for the filter field, quality and non-indels\n",
+        "   vcf-stats file.vcf.gz -f FILTER,QUAL=10:200,INFO/INDEL=False -p out/\n",
+        "\n",
+        "   # Calculate stats for all samples\n",
+        "   vcf-stats file.vcf.gz -f FORMAT/DP=10:200 -p out/\n",
+        "\n",
+        "   # Calculate stats only for the sample NA00001\n",
+        "   vcf-stats file.vcf.gz -f SAMPLE/NA00001/DP=1:200 -p out/\n",
+        "\n",
+        "   vcf-stats file.vcf.gz > perl.dump\n",
+        "\n";
+}
+
+
+sub parse_params
+{
+    my $opts = { filters=>{}, filter_param=>'' };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-d' || $arg eq '--dump'  ) { $$opts{dump}=shift(@ARGV); next; }
+        if ( $arg eq '-f' || $arg eq '--filters'  ) { $$opts{filter_param}=shift(@ARGV); next; }
+        if ( $arg eq '-p' || $arg eq '--prefix'  ) { $$opts{prefix}=shift(@ARGV); next; }
+        if ( $arg eq '-s' || $arg eq '--samples'  ) 
+        { 
+            my $samples = shift(@ARGV);
+            $$opts{samples} = [ split(/,/,$samples) ];
+            next;
+        }
+        if ( -e $arg ) { $$opts{file} = $arg; next }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        error("Unknown parameter or nonexistent file: \"$arg\". Run -h for help.\n");
+    }
+    if ( exists($$opts{dump}) && !exists($$opts{prefix}) ) { error("Expected -p option with -d.\n"); }
+    return $opts;
+}
+
+
+sub init_filters
+{
+    my ($opts,$vcf) = @_;
+
+    for my $filter (split(/,/,$$opts{filter_param}))
+    {
+        my ($key,$value) = split(/=/,$filter);
+
+        my $rec = { value=>$value, exact=>0, any=>0, bin=>0, is_flag=>0 };
+        if ( $key=~m{^INFO/} )
+        {
+            my $tag = $';
+            $$rec{tag} = $tag;
+            if ( exists($$vcf{header}{'INFO'}) && exists($$vcf{header}{'INFO'}{$tag}) && $$vcf{header}{'INFO'}{$tag}{Type} eq 'Flag' )
+            {
+                $$rec{is_flag} = 1;
+                $$rec{value} = $value eq 'False' ? 0 : 1;
+                $key = "INFO/$tag=". ($$rec{value} ? 'True':'False');
+            }
+        }
+        elsif ( $key eq 'INFO' )
+        {
+            # All INFO flags should be counted
+            for my $tag (keys %{$$vcf{header}{'INFO'}})
+            {
+                if ( $$vcf{header}{'INFO'}{$tag}{Type} ne 'Flag' ) { next; }
+                $$opts{filters}{"INFO/$tag=True"} = { %$rec, is_flag=>1, value=>1, tag=>$tag };
+            }
+            next;
+        }
+
+        if ( ! defined $value )
+        {
+            $$rec{any} = 1;
+        }
+        elsif ( $value=~/^(.+):(.+)$/ ) 
+        {
+            $$rec{bin}      = 1;
+            $$rec{bin_size} = $1;
+            $$rec{max}      = $2;
+        }
+        else
+        {
+            $$rec{exact} = 1;
+        }
+        $$opts{filters}{$key} = $rec;
+    }
+}
+
+
+sub vcf_stats
+{
+    my ($opts) = @_;
+
+    if ( exists($$opts{dump}) )
+    {
+        # Use existing dump to recreate the files
+        my $vcf = VcfStats->new(file=>'/dev/null');
+        $$vcf{stats} = do $$opts{dump};
+        $vcf->save_stats($$opts{prefix});
+        return;
+    }
+
+    # Open the VCF file
+    my $vcf = $$opts{file} ? VcfStats->new(file=>$$opts{file}) : VcfStats->new(fh=>\*STDIN);
+    $vcf->parse_header();
+    init_filters($opts,$vcf);
+
+    # Include only requested samples
+    if ( exists $$opts{samples} )
+    {   
+        my @include = ();
+        if ( scalar @{$$opts{samples}}>1 or $$opts{samples}[0] ne '-' ) 
+        { 
+            for my $sample (@{$$opts{samples}}) { push @include,$sample; }
+        }
+        $vcf->set_samples(include=>\@include); 
+    }
+
+    while (my $rec=$vcf->next_data_hash())
+    {
+       $vcf->collect_stats($rec,$$opts{filters});
+    }
+
+    $vcf->save_stats($$opts{prefix});
+}
+
+
+