ngs_server 0.1 → 0.2

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

@@ -0,0 +1,310 @@
+#!/usr/bin/env perl
+#
+# Author: petr.danecek@sanger
+#
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+my $opts = parse_params();
+if ( $$opts{check_columns} )
+{
+    check_columns($opts);
+}
+elsif ( !exists($$opts{sort}) )
+{
+    concat($opts);
+}
+else
+{
+    concat_merge($opts);
+}
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "About: Convenience tool for concatenating VCF files. In the basic mode it does not \n",
+        "   do anything fancy except for a sanity check that all files have the same columns.\n",
+        "   When run with the -s option, it will perform a partial merge sort, looking at\n",
+        "   a limited number of open jobs simultaneously.\n",
+        "Usage: vcf-concat [OPTIONS] A.vcf.gz B.vcf.gz C.vcf.gz > out.vcf\n",
+        "Options:\n",
+        "   -c, --check-columns              Do not concatenate, only check if the columns agree.\n",
+        "   -f, --files <file>               Read the list of files from a file.\n",
+        "   -s, --merge-sort <int>           Allow small overlaps in N consecutive files.\n",
+        "   -h, -?, --help                   This help message.\n",
+        "\n";
+}
+
+sub parse_params
+{
+    my $opts = { files=>[] };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-s' || $arg eq '--merge-sort' ) { $$opts{sort}=shift(@ARGV); next; } 
+        if ( $arg eq '-c' || $arg eq '--check-columns' ) { $$opts{check_columns}=1; next;  }
+        if ( $arg eq '-f' || $arg eq '--files' ) 
+        {
+            my $files = shift(@ARGV);
+            open(my $fh,'<',$files) or error("$files: $!");
+            while (my $line=<$fh>)
+            {
+                chomp($line);
+                push @{$$opts{files}},$line;
+            }
+            close($fh);
+            next;
+        }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        if ( -e $arg ) { push @{$$opts{files}},$arg; next }
+        error("Unknown parameter \"$arg\". Run -h for help.\n");
+    }
+    if ( ! @{$$opts{files}} ) { error("No files to concat?\n") }
+    return $opts;
+}
+
+sub check_columns
+{
+    my ($opts) = @_;
+    my @columns;
+    for my $file (@{$$opts{files}})
+    {
+        my $vcf = Vcf->new(file=>$file);
+        $vcf->parse_header();
+
+        if ( @columns )
+        {
+            if ( @columns != @{$$vcf{columns}} ) { warn("Different number of columns in [$file].\n"); }
+            for (my $i=0; $i<@columns; $i++)
+            {
+                if ( $$vcf{columns}[$i] ne $columns[$i] ) { warn("The column names do not agree in [$file].\n"); last; }
+            }
+        }
+        else
+        {
+            @columns = @{$$vcf{columns}};
+        }
+        $vcf->close();
+    }
+}
+
+sub concat
+{
+    my ($opts) = @_;
+    my @columns;
+    for my $file (@{$$opts{files}})
+    {
+        my $vcf = Vcf->new(file=>$file);
+        $vcf->parse_header();
+
+        if ( @columns )
+        {
+            if ( @columns != @{$$vcf{columns}} ) { error("Different number of columns in [$file].\n"); }
+            for (my $i=0; $i<@columns; $i++)
+            {
+                if ( $$vcf{columns}[$i] ne $columns[$i] ) { error("The column names do not agree in [$file].\n"); }
+            }
+        }
+        else
+        {
+            @columns = @{$$vcf{columns}};
+            print $vcf->format_header();
+        }
+        while (my $line=$vcf->next_line())
+        {
+            print $line;
+        }
+    }
+}
+
+sub get_chromosomes
+{
+    my ($files) = @_;
+    my @out;
+    my %has_chrm;
+    for my $file (@$files)
+    {
+        my $vcf = Vcf->new(file=>$file);
+        my $chrms = $vcf->get_chromosomes();
+        for my $chr (@$chrms)
+        {
+            if ( exists($has_chrm{$chr}) ) { next; }
+            $has_chrm{$chr} = 1;
+            push @out,$chr;
+        }
+    }
+    return \@out;
+}
+
+sub concat_merge
+{
+    my ($opts) = @_;
+
+    my $header_printed = 0;
+    my $chroms = get_chromosomes($$opts{files});
+    for my $chr (@$chroms)
+    {
+        my $reader = Reader->new(files=>$$opts{files},nsort=>$$opts{sort},seq=>$chr,header_printed=>$header_printed);
+        $header_printed = 1;
+        $reader->open_next();
+        while (1)
+        {
+            my $line = $reader->next_line();
+            if ( !defined $line )
+            {
+                if ( !$reader->open_next() ) { last; }
+                next;
+            }
+            print $line;
+        }
+    }
+    if ( !$header_printed )
+    {
+        my $vcf = Vcf->new(file=>$$opts{files}[0]);
+        $vcf->parse_header();
+        print $vcf->format_header();
+    }
+}
+
+#---------------------------------
+
+package Reader;
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+
+sub new
+{
+    my ($class,@args) = @_;
+    my $self = @args ? {@args} : {};
+    bless $self, ref($class) || $class;
+    if ( !$$self{files} ) { $self->throw("Expected the files option.\n"); }
+    if ( !$$self{nsort} ) { $$self{nsort} = 2; }
+    if ( $$self{nsort}>@{$$self{files}} ) { $$self{nsort} = scalar @{$$self{files}}; } 
+    $$self{idxs} = undef;
+    $$self{vcfs} = undef;
+    return $self;
+}
+
+sub throw
+{
+    my ($self,@msg) = @_;
+    confess @msg;
+}
+
+sub print_header
+{
+    my ($self,$vcf) = @_;
+    if ( $$self{header_printed} ) { return; }
+    print $vcf->format_header();
+    $$self{header_printed} = 1;
+}
+
+
+# Open VCF, parse header, check column names and when callled for the first time, output the VCF header.
+sub open_vcf
+{
+    my ($self,$file) = @_;
+    my $vcf = Vcf->new(file=>$file,region=>$$self{seq},print_header=>1);
+    $vcf->parse_header();
+    if ( !exists($$self{columns}) )
+    {
+        $$self{columns} = [ @{$$vcf{columns}} ];
+    }
+    else
+    {
+        if ( @{$$self{columns}} != @{$$vcf{columns}} ) { $self->throw("Different number of columns in [$file].\n"); }
+        for (my $i=0; $i<@{$$self{columns}}; $i++)
+        {
+            if ( $$vcf{columns}[$i] ne $$self{columns}[$i] ) { $self->throw("The column names do not agree in [$file].\n"); }
+        }
+    }
+    $self->print_header($vcf);
+    return $vcf;
+}
+
+sub open_next
+{
+    my ($self) = @_;
+
+    if ( !defined $$self{idxs} )
+    {
+        for (my $i=0; $i<$$self{nsort}; $i++)
+        {
+            $$self{idxs}[$i] = $i;
+        }
+    }
+    else
+    {
+        my $prev = $$self{idxs}[-1];
+
+        shift(@{$$self{idxs}});
+        shift(@{$$self{vcfs}});
+
+        if ( $prev+1 < @{$$self{files}} ) 
+        {
+            # New file to be opened
+            push @{$$self{idxs}}, $prev+1;
+        }
+    }
+    for (my $i=0; $i<@{$$self{idxs}}; $i++)
+    {
+        if ( exists($$self{vcfs}[$i]) ) { next; }
+        my $idx = $$self{idxs}[$i];
+        $$self{vcfs}[$i] = $self->open_vcf($$self{files}[$idx]);
+    }
+    if ( !@{$$self{idxs}} ) { return 0; }
+    return 1;
+}
+
+sub next_line
+{
+    my ($self) = @_;
+
+    my $min = $$self{vcfs}[0]->next_line();
+    if ( !defined $min ) { return undef; }
+
+    if ( !($min=~/^(\S+)\t(\d+)/) ) { $self->throw("Could not parse the line: $min\n"); }
+    my $min_chr = $1;
+    my $min_pos = $2;
+    my $min_vcf = $$self{vcfs}[0];
+
+    for (my $i=1; $i<@{$$self{vcfs}}; $i++)
+    {
+        if ( !exists($$self{vcfs}[$i]) ) { next; }
+        my $line = $$self{vcfs}[$i]->next_line();
+        if ( !defined $line ) { next; }
+        if ( !($line=~/^(\S+)\t(\d+)/) ) { $self->throw("Could not parse the line: $line\n"); }
+        my $chr = $1;
+        my $pos = $2;
+
+        if ( $chr ne $min_chr ) { $self->throw("FIXME: When run with the -s option, only one chromosome can be present.\n"); }
+        if ( $min_pos > $pos )
+        {
+            $min_pos = $pos;
+            $min_vcf->_unread_line($min);
+            $min_vcf = $$self{vcfs}[$i];
+            $min = $line;
+        }
+        else
+        {
+            $$self{vcfs}[$i]->_unread_line($line);
+        }
+    }
+    return $min;
+}
+
+

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

@@ -0,0 +1,180 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Carp;
+use Vcf;
+use FindBin;
+use lib "$FindBin::Bin";
+use FaSlice;
+
+my $opts = parse_params();
+convert_file($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+    my (@msg) = @_;
+    if ( scalar @msg )
+    {
+        croak @msg;
+    }
+    die
+        "About: Convert between VCF versions, currently to VCFv4.0 only.\n",
+        "Usage: cat in.vcf | vcf-convert [OPTIONS] > out.vcf\n",
+        "Options:\n",
+        "   -r, --refseq <file>              The reference sequence in samtools faindexed fasta file. (Not required with SNPs only.)\n",
+        "   -v, --version <string>           4.0\n",
+        "   -h, -?, --help                   This help message.\n",
+        "\n";
+}
+
+
+sub parse_params
+{
+    my $opts = { version=>'4.0' };
+    while (my $arg=shift(@ARGV))
+    {
+        if ( $arg eq '-r' || $arg eq '--refseq' ) { $$opts{refseq}=shift(@ARGV); next; }
+        if ( $arg eq '-v' || $arg eq '--version' ) { $$opts{version}=shift(@ARGV); next; }
+        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+        error("Unknown parameter \"$arg\". Run -h for help.\n");
+    }
+    return $opts;
+}
+
+
+sub convert_file
+{
+    my ($opts) = @_;
+
+    if ( $$opts{version} ne '4.0' ) { error("Sorry, 4.0 is currently the only supported output version.\n"); }
+
+    # How to recognise a number
+    my $FLOAT_RE = qr/^\-?\d+\.?\d*(?:[eE][+-]\d+)?$/;
+
+    my $vcf_in  = Vcf->new(fh=>\*STDIN);
+    my $vcf_out = Vcf->new(version=>'4.0');
+
+    # Convert the header
+    $vcf_in->parse_header();
+    for (my $i=1; $i<@{$$vcf_in{header_lines}}; $i++)
+    {
+        $vcf_out->add_header_line($$vcf_in{header_lines}[$i]);
+    }
+    $vcf_out->add_columns(@{$$vcf_in{columns}});
+    print $vcf_out->format_header();
+
+    # Convert each data line
+    my $fa;
+    while (my $x=$vcf_in->next_data_hash())
+    {
+        # Convert missing (default) FORMAT values
+        for my $gt (values %{$$x{gtypes}})
+        {
+            for my $field (@{$$x{FORMAT}})
+            {
+                # Skip the GT tag, so that ploidy information is not lost ("./." would become ".")
+                if ( $field eq 'GT' ) { next; }
+                if ( $field eq 'FT' && $$gt{$field} eq $$vcf_in{filter_passed} ) { $$gt{$field}=$$vcf_out{filter_passed}; }
+                if ( exists($$vcf_in{defaults}{$field}) && $$vcf_in{defaults}{$field} eq $$gt{$field} )
+                {
+                    $$gt{$field} = $$vcf_out{defaults}{$field};
+                    next;
+                }
+                if ( exists($$vcf_in{header}{FORMAT}{$field}{default}) && $$vcf_in{header}{FORMAT}{$field}{default} eq $$gt{$field} )
+                {
+                    delete($$gt{$field});
+                    next;
+                }
+            }
+        }
+
+
+        # Change missing QUAL: In case they are numbers, do numeric comparison, as -1.0 is sometimes used instead of -1
+        if ( $$x{QUAL} eq $$vcf_in{defaults}{QUAL} 
+            or ($$x{QUAL}=~$FLOAT_RE && $$vcf_in{defaults}{QUAL}=~$FLOAT_RE && $$x{QUAL}==$$vcf_in{defaults}{QUAL}) ) 
+        { 
+            $$x{QUAL} = $$vcf_out{defaults}{QUAL}; 
+        }
+        for (my $i=0; $i<@{$$x{FILTER}}; $i++)
+        {
+            if ( $$x{FILTER}[$i] eq $$vcf_in{filter_passed} ) { $$x{FILTER}[$i] = $$vcf_out{filter_passed}; }
+        }
+
+        # Parse the ALT column and see if there are indels
+        my $has_indel = 0;
+        for my $alt (@{$$x{ALT}})
+        {
+            my ($type,$len,$ht) = $vcf_in->event_type($x,$alt);
+            if ( $type eq 's' or $type eq 'r' ) { next; }
+            if ( $type ne 'i' ) { error("FIXME: expected indel at $$x{CHROM}:$$x{POS}\n"); }
+
+            $has_indel = 1;
+        }
+
+        # If there is an indel, new REF and ALT must be changed
+        if ( $has_indel )
+        {
+            my $map = {};
+            my $alt_to_mapref = {};
+
+            for my $alt (@{$$x{ALT}})
+            {
+                my ($type,$len,$ht) = $vcf_in->event_type($x,$alt);
+                if ( $type eq 's' or $type eq 'r' )
+                {
+                    $$alt_to_mapref{$alt} = { ref=>$$x{REF}, alt=>$alt };
+                    $$map{$$x{REF}}{$alt} = 1;
+                    next;
+                }
+
+                if ( $type eq 'i' && $len>0 )
+                {
+                    my $tmp = $$x{REF}.$ht;
+                    $$alt_to_mapref{$alt} = { ref=>$$x{REF}, alt=>$tmp };
+                    $$map{$$x{REF}}{$tmp} = 1;
+                    next;
+                }
+                elsif ( $type eq 'i' && $len<0 )
+                {
+                    if ( !$fa )
+                    {
+                        if ( !$$opts{refseq} ) { error("Indels present, missing the -r option.\n"); }
+                        $fa = FaSlice->new(file=>$$opts{refseq},size=>1_000_000);
+                    }
+                    my $ref   = $fa->get_slice($$x{CHROM},$$x{POS},$$x{POS}+abs($len));
+                    my $first = substr($ref,0,1);
+
+                    # Sanity check
+                    if ( $$x{REF} ne $first ) 
+                    { 
+                        error("Sanity check failed: the ref does not agree at $$x{CHROM}:$$x{POS} .. [$$x{REF}] in .fa,  [$first] in .vcf\n"); 
+                    }
+
+                    $$alt_to_mapref{$alt} = { ref=>$ref, alt=>$$x{REF} };
+                    $$map{$ref}{$$x{REF}} = 1;
+                    next;
+                }
+                else 
+                { 
+                    error("Uh, FIXME: $$x{CHROM}:$$x{POS} [$type] [$len] [$ht]\n"); 
+                }
+            }
+
+            $$x{REF} = $vcf_out->fill_ref_alt_mapping($map);
+            for (my $i=0; $i<@{$$x{ALT}}; $i++)
+            {
+                my $ori_ref = $$alt_to_mapref{$$x{ALT}[$i]}{ref};
+                my $ori_alt = $$alt_to_mapref{$$x{ALT}[$i]}{alt};
+                $$x{ALT}[$i] = $$map{$ori_ref}{$ori_alt};
+            }
+        }
+
+        print $vcf_out->format_line($x);
+    }
+}
+

data/ext/vcftools/perl/.svn/text-base/vcf-fix-newlines.svn-base

@@ -0,0 +1,97 @@
+#!/usr/bin/env perl
+#
+# Authors: Adam Auton, Petr Danecek
+# (C) 2011
+
+use strict;
+use warnings;
+use Carp;
+
+my $opts = parse_params();
+fix_file($opts);
+
+exit;
+
+#--------------------------------
+
+sub error
+{
+	my (@msg) = @_;
+	if ( scalar @msg ) { confess @msg; }
+	die
+		"About: Reads in a VCF file with any (commonly used) newline representation and outputs with the\n",
+		"	current system's newline representation.\n",
+		"Usage: vcf-fix-newlines [OPTIONS]\n",
+		"Options:\n",
+		"   -i, --info                      Report if the file is consistent with the current platform based.\n",
+		"   -h, -?, --help                  This help message.\n",
+		"Example:\n",
+		"	vcf-fix-newlines -i file.vcf\n",
+		"	vcf-fix-newlines file.vcf.gz > out.vcf\n",
+		"	cat file.vcf | vcf-fix-newlines > out.vcf\n",
+		"\n";
+}
+
+sub parse_params
+{
+	my $opts = {};
+	while (defined(my $arg=shift(@ARGV)))
+	{
+		if ( $arg eq '-i' || $arg eq '--info' ) { $$opts{info}=1; next }
+		if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { error(); }
+		if ( !exists($$opts{vcf}) && -e $arg ) { $$opts{vcf}=$arg; next; }
+		error("Unknown parameter \"$arg\". Run -h for help.\n");
+	}
+	return $opts;
+}
+
+sub fix_file
+{
+	my ($opts) = @_;
+
+	my $fh = \*STDIN;
+	if ( $$opts{vcf} )
+	{
+		if ( $$opts{vcf}=~/\.gz/i )
+		{
+			open($fh,"gunzip -c $$opts{vcf} |") or error("gunzip -c $$opts{vcf}: $!\n");
+		}
+		else
+		{
+			open($fh,'<',$$opts{vcf}) or error("$$opts{vcf}: $!\n");
+		}
+	}
+
+	# Read a small 1kb sample
+	binmode $fh or error("binmode: $!");
+	local $/ = \1024;
+	my $buf  = <$fh>;
+	if ( !defined $buf ) { error("No data read.\n"); }
+
+	# Check the origin
+	my ($in,$nl);
+	if ( $buf=~/\015\012/ ) { $in = 'Windows'; $nl=$&; }
+	elsif ( $buf=~/\015/ && !($buf=~/\012/) ) { $in = 'Old Mac'; $nl=$&; }
+	elsif ( $buf=~/\012/ && !($buf=~/\015/) ) { $in = 'UNIX'; $nl=$&; }
+	else
+	{
+		error("FIXME: Unable to determine the system which produced the file.\n");
+	}
+	if ( defined $in ) { warn("The file was generated on $in compatible system.\n"); }
+	if ( $$opts{info} ) { close($fh); return; }
+	if ( $nl eq "\n" ) { warn("No conversion needed.\n"); return; }
+
+	# Read the file and do the conversion
+	local $/ = $nl;
+	$buf .= <$fh>;
+	$buf =~ s/$nl/\n/g;
+	print $buf;
+
+	while($buf = <$fh>)
+	{
+		$buf =~ s/$nl/\n/g;
+		print $buf;
+	}
+	close($fh);
+}
+