#!/usr/bin/perl -w
#
# BAT_SNPs.pl
#
# Development script to parse Maq pileup file from alignment of
# munged barcoded Illumina reads from DH lines vs munged pseudoref seqs
#
# See also companion scripts "mung_barcoded_reads.pl" and "mung_refs.pl"
#
# Martin.Trick@bbsrc.ac.uk, 7/9/2009
#
#
# ===================================================================

unless (@ARGV == 2) {
  print "Usage: BAT_SNPs.pl <pileup file> <barcode lookup file>\n";
  exit;
}

# Debug messages
my $DEBUG = 10;
# Flag for considering only pre-defined SNPs (listed in %snps hash)
my $targeted = 1;

# Hash to hold all allele frequencies across targets and barcodes
my %data = ();

# Hash for barcodes
my %codes = ();

# Hash for IUB uncertainty codes (and its inverse for lookups)
my %iub = ( M => 'AC', K => 'GT', Y => 'CT', R => 'AG', W => 'AT', S => 'CG', D => 'AGT', B => 'CGT', H => 'ACT', V => 'ACG', N => 'ACGT');
my %reverse = reverse %iub;

# Hard-coded hack - ideally these SNP positions would be read from a file
# Each key (eg S00002) corresponds to a PCR amplicon target
my %snps = (S00001 => [22,31], S00002 => [27,40], S00003 => [22,25,34], S00006 => [34], S00007 => [35,54,71], S00008 => [35], S00009 => [22,23], S00010 => [22,37], S00012 => [26,35], S00014 => [26], S00015 => [34], S00016 => [32], S00018 => [33], S00019 => [25], S00020 => [20,25,38], S00021 => [22], S00022 => [25], S00023 => [25,49], S00026 => [24], S00029 => [26], S00030 => [30], S00031 => [26], S00032 => [23,26], S00033 => [23,29,44,47,57,75], S00034 => [28], S00035 => [21], S00036 => [27,36,39], S00037 => [26], S00038 => [29], S00039 => [26], S00040 => [22,25,34,43,45], S00041 => [21,51], S00042 => [30], S00044 => [22], S00045 => [30],);

# M13 primer sequence
my $m13 = 'TGTAAAACGACGGCCAGT';

# Variables
# First part of aligned read comprises munged barcode (24nt) and M13 (18nt)
my $clip = 42;
# Minimum read depth
my $depth_threshold = 20;
# Q value threshold
my $q_threshold = 15;
# Percentage minority call threshold, there's already an implicit 1%
# from the round() function
my $r_threshold = 5;

# Barcode lookup file is tabbed text: plant lines and barcodes, e.g.
# TN01     B00003
# TN05     B00004
# TN10     B00005

open (BARCODES, "<$ARGV[1]") or die "Couldn't open barcode lookup file ($!)\n";
while (<BARCODES>) {
  chomp;
  s/\r//g; # FTP?
  my @cols = split;
  $codes{$cols[0]} = $cols[1]; # Key barcodes by plant line number
}
close BARCODES;

open (PILEUP, "<$ARGV[0]") or die "Couldn't open Maq pileup file ($!)\n";
print "Reading in pileup file...\n";
while (<PILEUP>) {
  @cols = ();
  @calls = ();
  %calls = ();
  @qualities = ();
  $hq = 0;

  @cols = split;
  next if ($cols[3] <= $depth_threshold); # Poor read-depth

# Each pseudo-reference id comprises a barcode (plant line) and a target
# e.g. B00003-S00032
  ($barcode,$target) = $cols[0] =~ /(\w+)\-([\w\-]+)/;

  # Only consider the target region beyond the primer
  next unless ($cols[1] > $clip);

  # Next unless it's a known SNP position?
  if ($targeted) {
    $snp = 0;
    foreach $p (@{$snps{$target}}) {
      if (($cols[1] - $clip) == $p) {
	$snp = 1;
	last;
      }
    }
    next unless ($snp);
  }

  # Else parse the calls and the qualities
  push @calls, split //, $cols[4];
  push @qualities, split //, $cols[5] if (defined $cols[5]);
  foreach $q (1 .. $#qualities) { # Skips the '@'
    $qualities[$q] = ord($qualities[$q]) - 33;
  }
  unless (@calls == 0) {
    foreach my $call(1 .. $#calls) { # Skip '@' char
      $calls[$call] =~ s/[.,]/$cols[2]/;
      $calls[$call] =~ tr/acgtn/ACGTN/; # Ignore flaky use of case
      $calls{$calls[$call]}++ unless ($qualities[$call] <= $q_threshold);
    }
  }
  # Create allele frequency string array
  foreach $key(keys %calls) {$hq += $calls{$key}; }
  foreach $key(sort keys %calls) {
    $f = round((($calls{$key}/$hq)*100));
    push @{$data{$target}{$cols[1]}{$barcode}}, "$key\[$f\]" if ($f > $r_threshold);
  }
}
print "...  done\n";
close PILEUP;

# Do the allele scoring
TARGET:foreach my $target (sort keys %data) {
 POS: foreach my $pos (sort {$a <=> $b} keys %{$data{$target}}) {
    my $scores = '';
    my %alleles = ();
    print "$target:" . ($pos - $clip) . "\n" if $DEBUG;
  LINE: foreach my $line(sort {$b <=> $a} keys %codes) {
      $barcode = $codes{$line};
      if (! exists $data{$target}{$pos}{$barcode} ||
	  @{$data{$target}{$pos}{$barcode}} == 0) {
	$scores .= '- '; # No data, as opposed to a non-parental allele
	next LINE;
      }
      # Else extract the call frequencies and construct the allele
      my @mixture = ();
      my $mixture = '';
      my $call;
      foreach $f(0 .. $#{@{$data{$target}{$pos}{$barcode}}}) {
	($call,$percent) = $data{$target}{$pos}{$barcode}[$f] =~ /([ACGT])\[(\d+)\]/;
	push @mixture, $call if ($percent >= $r_threshold);

      }
      print "Line $line: " . "@{$data{$target}{$pos}{$barcode}}" if $DEBUG;
      @mixture = sort {$a cmp $b} @mixture;
      $mixture = join '', @mixture;
      # Make the call
      $call = (@mixture == 1) ? $mixture[0] : $reverse{$mixture};
      # Store the parental calls; B00065 - A (Tapidor); B00066 - B (Ningyou)
      # Hard-code here but could be made more portable
      if ($barcode =~ /65/ || $barcode =~ /66/) {
	$parent = ($barcode =~ /65/) ? 'A' : 'B';
	$alleles{$parent} = $call;
	if ($DEBUG) {
	  print " Parental line (Barcode $barcode) ";
	  print "Frequency string ";
	  foreach $f(0 .. $#{@{$data{$target}{$pos}{$barcode}}}) {
	    print "$data{$target}{$pos}{$barcode}[$f]";
	  }
	  print " Setting allele $parent to $call\n";
	}
	next LINE;
      }
      else {
	unless (exists $alleles{A} && exists $alleles{B}) {
	  print "$target:" . ($pos - $clip) . " skipping: parental alleles were not divined\n" if $DEBUG;
	    next POS;
	}
	if ($alleles{A} eq $alleles{B}) {
	  # Monomorphic, so skip this position
	  print "$target:" . ($pos - $clip) . " skipping: no polymorphism\n" if $DEBUG;
	  next POS;
	}
	my $match = 0;
	foreach $parent(keys %alleles) {
	  if ($alleles{$parent} eq $call) {
	    print " - allele $parent\n" if $DEBUG;
	    $match = 1;
	    last;
	  }
	}
	unless ($match) {
	  print " - Non-parental allele\n" if $DEBUG;
	  $scores .= 'U ';
	}
      }
    }
    $scores = reverse($scores);
    # Transform position relative to the end of M13 primer
    print "$target:" . ($pos - $clip) . "\t$scores\n";
  }
}


sub round {
    my ($number) = shift;
    return int($number + .5);
}
