ngs_server 0.1 → 0.2

data/ext/vcftools/perl/.svn/text-base/vcf-subset.svn-base

@@ -0,0 +1,206 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+my $opts = parse_params();
+vcf_subset($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "Usage: vcf-subset [OPTIONS] in.vcf.gz > out.vcf\n",
+        "Options:\n",
+        "   -c, --columns <string>           File or comma-separated list of columns to keep in the vcf file. If file, one column per row\n",
+        "   -e, --exclude-ref                Exclude rows not containing variants.\n",
+        "   -f, --force                      Proceed anyway even if VCF does not contain some of the samples.\n",
+        "   -p, --private                    Print only rows where only the subset columns carry an alternate allele.\n",
+        "   -r, --replace-with-ref           Replace the excluded types with reference allele instead of dot.\n",
+        "   -t, --type <list>                Comma-separated list of variant types to include: SNPs,indels.\n",
+        "   -u, --keep-uncalled              Do not exclude rows without calls.\n",
+        "   -h, -?, --help                   This help message.\n",
+        "Examples:\n",
+        "   cat in.vcf | vcf-subset -r -t indels -e -c SAMPLE1 > out.vcf\n",
+        "\n";
+}
+
+
+sub parse_params
+{
+    my $opts = { exclude_ref=>0, keep_uncalled=>0, replace_with_ref=>0, private=>0, args=>[$0, @ARGV] };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-t' || $arg eq '--type' ) 
+        { 
+            my %known = ( SNPs=>'s', indels=>'i' );
+            my $types = shift(@ARGV);
+            for my $t (split(/,/,$types))
+            {
+                if ( !(exists($known{$t})) ) { error("Unknown type [$t] with -t [$types]\n"); }
+                $$opts{types}{$known{$t}} = 1;
+            }
+            next;
+        }
+        if ( $arg eq '-e' || $arg eq '--exclude-ref' ) { $$opts{'exclude_ref'} = 1; next }
+        if ( $arg eq '-f' || $arg eq '--force' ) { $$opts{'force'} = 1; next }
+        if ( $arg eq '-p' || $arg eq '--private' ) { $$opts{'private'} = 1; next }
+        if ( $arg eq '-r' || $arg eq '--replace-with-ref' ) { $$opts{'replace_with_ref'} = 1; next }
+        if ( $arg eq '-u' || $arg eq '--keep-uncalled' ) { $$opts{'keep_uncalled'} = 1; next }
+        if ( $arg eq '-c' || $arg eq '--columns' ) { $$opts{'columns_file'} = shift(@ARGV); next }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( -e $arg ) { $$opts{file} = $arg; next }
+        if ( -e $arg or $arg=~m{^(?:ftp|http)://} ) { $$opts{file}=$arg; next; }
+        error("Unknown parameter \"$arg\". Run -h for help.\n");
+    }
+    if ( !$$opts{exclude_ref} && !$$opts{'columns_file'} && !exists($$opts{'types'}) ) { error("Missing the -c or -t or -r option.\n") }
+    if ( exists($$opts{types}) ) { $$opts{types}{r}=1; }
+    return $opts;
+}
+
+
+sub read_columns
+{
+    my ($fname) = @_;
+    my @columns;
+    if ( !-e $fname )
+    {
+        @columns = split(/,/,$fname);
+        return \@columns;
+    }
+    open(my $fh,'<',$fname) or error("$fname: $!"); 
+    while (my $line=<$fh>)
+    {
+        chomp($line);
+        $line=~s/\s+//g;
+        push @columns, $line;
+    }
+    close($fh);
+    return \@columns;
+}
+
+sub check_columns
+{
+    my ($opts,$vcf,$columns) = @_;
+    my @out;
+    for my $col (@$columns)
+    {
+        if ( exists($$vcf{has_column}{$col}) ) 
+        { 
+            push @out, $col;
+            next; 
+        }
+
+        my $msg = qq[No such column in the VCF file: "$col"\n];
+        if ( $$opts{force} ) { warn($msg); }
+        else { error($msg); }
+    }
+    return \@out;
+}
+
+sub vcf_subset
+{
+    my ($opts) = @_;
+
+    my $vcf = $$opts{file} ? Vcf->new(file=>$$opts{file}) : Vcf->new(fh=>\*STDIN);
+    $vcf->parse_header();
+
+    # Init requested column info. If not present, include all columns.
+    my $columns = exists($$opts{columns_file}) ? read_columns($$opts{columns_file}) : [];
+    $columns = check_columns($opts,$vcf,$columns);
+    if ( !@$columns && (my $ncols=@{$$vcf{columns}})>9 )
+    {
+        push @$columns, @{$$vcf{columns}}[9..($ncols-1)];
+    }
+    my %has_col = map { $_ => 1 } @$columns;
+
+    $vcf->add_header_line({key=>'source',value=>join(' ',@{$$opts{args}})},append=>'timestamp');
+    $vcf->set_samples(include=>$columns) unless $$opts{private};
+    print $vcf->format_header($columns);
+
+    my $check_private = $$opts{private};
+    while (my $x=$vcf->next_data_hash())
+    {
+        my $site_has_call   = 0;
+        my $site_has_nonref = 0;
+        my $site_is_private = 1;
+        my $ref = $$x{REF};
+
+        for my $col (keys %{$$x{gtypes}})
+        {
+            if ( !$has_col{$col} && ($site_is_private==0 || !$check_private) ) 
+            { 
+                # This column is not to be printed
+                delete($$x{gtypes}{$col}); 
+                next;
+            }
+
+            my ($alleles,$seps,$is_phased,$is_empty) = $vcf->parse_haplotype($x,$col);
+            my $sample_has_call = 0;
+            my $sample_has_nonref = 0;
+            my @out_alleles;
+
+            for (my $i=0; $i<@$alleles; $i++)
+            {
+                my ($type,$len,$ht) = $vcf->event_type($ref,$$alleles[$i]);
+                $out_alleles[$i] = $$alleles[$i];
+
+                # Exclude unwanted variant types if requested
+                if ( exists($$opts{types}) )
+                {
+                    if ( !exists($$opts{types}{$type}) )
+                    {
+                        $out_alleles[$i] = $$opts{replace_with_ref} ? $ref : '.';
+                        next;
+                    }
+                    $sample_has_call = 1;
+                }
+                elsif ( !$is_empty ) { $sample_has_call = 1; }
+                if ( $type ne 'r' ) { $site_has_nonref = 1; $sample_has_nonref = 1; }
+            }
+            if ( $check_private && !$has_col{$col} )
+            {
+                if ( $sample_has_nonref ) { $site_is_private=0; }
+                delete($$x{gtypes}{$col});
+                next;
+            }
+            if ( !$sample_has_call )
+            {
+                if ( $$opts{replace_with_ref} )
+                {
+                    for (my $i=0; $i<@$alleles; $i++) { $out_alleles[$i] = $ref; }
+                }
+                else
+                {
+                    for (my $i=0; $i<@$alleles; $i++) { $out_alleles[$i] = '.'; }
+                }
+            }
+            else
+            {
+                $site_has_call = 1;
+            }
+            $$x{gtypes}{$col}{GT} = $vcf->format_haplotype(\@out_alleles,$seps);
+        }
+
+        if ( !$site_has_call && !$$opts{keep_uncalled} ) { next; }
+        if ( !$site_has_nonref && $$opts{exclude_ref} ) { next; }
+        if ( $check_private && (!$site_is_private || !$site_has_nonref) ) { next; }
+
+        $vcf->format_genotype_strings($x);
+        print $vcf->format_line($x,$columns);
+    }
+}
+

data/ext/vcftools/perl/.svn/text-base/vcf-to-tab.svn-base

@@ -0,0 +1,112 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+my $opts = parse_params();
+convert_to_tab($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "Usage: vcf-to-tab [OPTIONS] < in.vcf > out.tab\n",
+        "Options:\n",
+        "   -h, -?, --help                   This help message.\n",
+        "   -i, --iupac                      Use one-letter IUPAC codes\n",
+        "\n";
+}
+
+
+sub parse_params
+{
+    my $opts = { iupac=>0 };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( $arg eq '-i' || $arg eq '--iupac' ) { $$opts{iupac}=1; next; }
+        error("Unknown parameter \"$arg\". Run -h for help.\n");
+    }
+
+    if ( $$opts{iupac} )
+    {
+        $$opts{iupac} = 
+        {
+            'GG' => 'G',
+            'CC' => 'C',
+            'TT' => 'T',
+            'AA' => 'A',
+
+            'GT' => 'K',
+            'TG' => 'K',
+            'AC' => 'M',
+            'CA' => 'M',
+            'CG' => 'S',
+            'GC' => 'S',
+            'AG' => 'R',
+            'GA' => 'R',
+            'AT' => 'W',
+            'TA' => 'W',
+            'CT' => 'Y',
+            'TC' => 'Y',
+
+            '..' => '.',
+        };
+    }
+
+    return $opts;
+}
+
+
+sub convert_to_tab
+{
+    my ($opts) = @_;
+
+    my $iupac;
+    if ( $$opts{iupac} ) { $iupac=$$opts{iupac}; }
+
+    my $vcf = Vcf->new(fh=>\*STDIN);
+    $vcf->parse_header();
+
+    my $header_printed=0;
+
+    while (my $x=$vcf->next_data_hash())
+    {
+        if ( !$header_printed ) 
+        {
+            print "#CHROM\tPOS\tREF";
+            for my $col (sort keys %{$$x{gtypes}})
+            {
+                print "\t$col";
+            }
+            print "\n";
+
+            $header_printed = 1;
+        }
+
+        print "$$x{CHROM}\t$$x{POS}\t$$x{REF}";
+        for my $col (sort keys %{$$x{gtypes}})
+        {
+            my ($al1,$sep,$al2) = exists($$x{gtypes}{$col}{GT}) ? $vcf->parse_alleles($x,$col) : ('.','/','.');
+            my $gt = $al1.'/'.$al2;
+            if ( $iupac )
+            {
+                if ( !exists($$iupac{$gt}) ) { error(qq[Unknown IUPAC code for "$al1$sep$al2" .. $$x{CHROM}:$$x{POS} $col\n]); }
+                $gt = $$iupac{$gt};
+            }
+            print "\t".$gt;
+        }
+        print "\n";
+    }
+}
+

data/ext/vcftools/perl/.svn/text-base/vcf-validator.svn-base

@@ -0,0 +1,145 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+use IPC::Open3 'open3';
+use IO::Select;
+
+my $opts = parse_params();
+do_validation($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "Usage: vcf-validator [OPTIONS] file.vcf.gz\n",
+        "Options:\n",
+        "   -d, --duplicates                 Warn about duplicate positions.\n",
+        "   -u, --unique-messages            Output all messages only once.\n",
+        "   -h, -?, --help                   This help message.\n",
+        "\n";
+}
+
+
+sub parse_params
+{
+    my $opts = { unique=>0, duplicates=>0 };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-d' || $arg eq '--duplicates' ) { $$opts{duplicates}=1; next; }
+        if ( $arg eq '-u' || $arg eq '--unique-messages' ) { $$opts{unique}=1; next; }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( -e $arg && !exists($$opts{file}) ) { $$opts{file}=$arg; next; }
+        error("Unknown parameter or non-existent file: \"$arg\". Run -h for help.\n");
+    }
+    return $opts;
+}
+
+sub do_validation
+{
+    my ($opts) = @_;
+
+    my %opts = $$opts{file} ? (file=>$$opts{file}) : (fh=>\*STDIN);
+    my $vcf = Vcf->new(%opts, warn_duplicates=>$$opts{duplicates});
+
+    if ( !$$opts{unique} )
+    {
+        $vcf->run_validation();
+        return;
+    }
+
+    my ($kid_in,$kid_out,$kid_err);
+
+    my $pid = open3($kid_in,$kid_out,$kid_err,'-');
+    if ( !defined $pid ) { error("Cannot fork: $!"); }
+
+    if ($pid)
+    {
+        $$opts{known_lines} = [];
+
+        my $sel = new IO::Select;
+        $sel->add($kid_out,$kid_err);
+
+        while(my @ready = $sel->can_read) 
+        {
+            foreach my $fh (@ready) 
+            {
+                my $line = <$fh>; 
+                if (not defined $line) 
+                {
+                    $sel->remove($fh); 
+                    next;         
+                }
+                print_or_discard_line($opts,$line);
+            }
+        }
+        print_summary($opts);
+    } 
+    else 
+    {
+        $vcf->run_validation();
+        return;
+    }
+}
+
+sub print_or_discard_line
+{
+    my ($opts,$line) = @_;
+
+    my @items  = split(/\s+/,$line);
+    my $nitems = scalar @items;
+
+    for my $known (@{$$opts{known_lines}})
+    {
+        if ( @items != @{$$known{line}} ) { next; }
+
+        my $nmatches = 0;
+        for (my $i=0; $i<$nitems; $i++)
+        {
+            if ( $items[$i] eq $$known{line}[$i] ) { $nmatches++ }
+        }
+
+        if ( $nitems-$nmatches<3 ) 
+        { 
+            $$known{n}++;
+            return; 
+        }
+    }
+
+    push @{$$opts{known_lines}}, { line=>\@items, n=>1 };
+    print $line;
+}
+
+sub print_summary
+{
+    my ($opts) = @_;
+    my $n = 0;
+    for my $error (@{$$opts{known_lines}})
+    {
+        $n += $$error{n};
+    }
+    print "\n\n------------------------\n";
+    print "Summary:\n";
+    printf "\t%d errors total \n\n", $n;
+
+    $n = 0;
+    for my $error (sort {$$b{n}<=>$$a{n}} @{$$opts{known_lines}})
+    {
+        if ( $n++ > 50 ) { print "\n\nand more...\n"; last; }
+        printf "\t%d\t..\t%s\n", $$error{n},join(' ',@{$$error{line}});
+    }
+}
+

data/ext/vcftools/perl/ChangeLog

@@ -0,0 +1,84 @@
+2011-04-04 14:00  petr.danecek@sanger
+    * VCFtools now support VCFv4.1
+    * fill-ref-md5: New tool backfilling sequence MD5s into VCF header
+    * Renamed merge-vcf, compare-vcf etc. to consistent naming vcf-merge, vcf-compare
+    * vcf-merge: Now merging also GL and other Number=[AG] tags
+    * vcf-compare: Comparing indel haplotypes
+
+2011-02-21 12:31  petr.danecek@sanger
+    * vcf-stats: new -s option to speed up parsing when stats computed for selected samples only
+    * merge-vcf: allow to merge arbitrary chunks; -c option now deprecated, use -r instead
+    * compare-vcf: change in output format and more detailed comparison
+
+2011-02-17 17:36  petr.danecek@sanger
+    * vcf-stats: allow querying stats of individual samples
+
+2011-02-16 12:07  petr.danecek@sanger
+    * vcf-stats: major revision
+    * vcf-annotate: more filtering options
+
+2011-02-04 14:43  petr
+    * merge-vcf: if possible, calculate AC,AN even for sites without genotypes
+
+2011-02-03 15:04  petr
+    * merge-vcf: fixed a bug introduced by the previous fix.
+
+2011-02-02 21:02  petr
+    * merge-vcf: fixed a bug in merging indel ALTs. Only VCFs without samples were affected. 
+
+2011-01-28 15:38  petr
+    * vcf-subset: new option for printing rows with calls private to the subset group
+
+2011-01-24 13:38  petr
+    * Vcf.pm: uppercase floating point number expressions (such as
+    1.0382033E-6) now pass validation
+
+2011-01-20 08:28  petr
+    * vcf-concat: print header also for empty VCFs with the -s option
+
+2011-01-04 08:59  petr
+    * vcf-isec, vcf-sort, Vcf.pm: replaced "zcat" by "gunzip -c"
+
+2010-12-22 14:18  petr
+    * vcf-annotate: New --SnpCluster option
+    * Vcf.pm: new sub add_filter()
+
+2010-12-15 13:44  petr
+    * vcf-isec: By default output records from all files with unique positions
+    (duplicate records from the same file still should be printed). With the -o
+    switch, only positions from the left-most file will be printed.
+
+2010-12-09 14:48  petr
+    * query-vcf: Output 'True' for Flag tags when present and . when absent
+    * vcf-annotate: Fix: the command line eats quotes when they are not escaped
+
+2010-12-08 12:06  petr
+    * Vcf.pm: throw an error when tabix fails.
+    * query-vcf: enable streaming of files when region is not specified.
+
+2010-12-02 11:53  petr
+    * Vcf.pm: allow ALT alleles which are not present in samples
+    * vcf-isec: Multiple files can be created simultaneously with all possible
+    isec combinations. Suitable for Venn Diagram analysis.
+    * merge-vcf: Do not remove ALT alleles if no samples are present
+    * merge-vcf: Do FILTER merging more intelligently.
+    * merge-vcf: Join the QUAL column: use average value weighted by the number of samples.
+
+2010-11-28 08:34  petr
+    * vcf-concat: Partial sort
+    * vcf-validator: Added -u option
+    * VcfStats.pm: dump_counts
+
+2010-11-27 13:04  petr
+    * vcf-subset: Filter variants by type
+
+2010-11-26 09:08  petr
+    * vcf-annotate: Added possibility to read header descriptions from a file
+
+2010-11-24 13:25  petr
+    * Fix in Vcf.pm:fill_ref_alt_mapping. VCF files processed with merge-vcf were
+    affected when containing IDs in the ALT column.
+
+2010-11-23 13:12  petr
+    * Major revamp of Vcf.pm to allow better inheritance. Problems likely.
+