#!/usr/bin/perl

#a script to take a fasta file and accompanying annotation (sequin ".tbl" format) along with the results from 454 variant mapping (454HCDiffs.txt) and summarize the identified variants.

use strict;
use warnings;

my $usage = "\n$0 454HCDiffs_file tbl_file fasta_file\n\n";

my $hcdiffsFile = shift or die ($usage);
my $tblFile = shift or die ($usage);
my $fastaFile = shift or die ($usage);

#print header
print "Variant\tSequence\tStartPosition\tEndPosition\tReference\tVariant\tReadDepth\tFrequency\tGenic/Intergenic\tGeneType\tGene\tStrand\tIntron/Exon\tGenePosition\tCodonPosition\tReferenceCodon\tAlternativeCodon\tReferenceAminoAcid\tVariantAminoAcid\tSyn/Non-Syn\n";

#generate hash of fasta headers and associated seqs
my %fastaHash = arrays2hash(get_fasta_names_and_seqs ($fastaFile));

#parse tbl file
my %tbl_HoHoA = parse_tbl_file ($tblFile);

#parse HCDiffs
my $FH_HCD = open_file ($hcdiffsFile);


my $clear_line = <$FH_HCD>; #clear top two header lines
$clear_line = <$FH_HCD>;

while (my $line = <$FH_HCD>){
	$line =~ /^>/ or next; #only use lines beginning with ">"
	chomp $line;
	my @splitLine = split (/\t/, $line);
	if ($splitLine[1] == $splitLine[2] and $splitLine[3] ne '-' and $splitLine[4] ne '-' and length ($splitLine[4]) == 1){
		print "SNP\t";
		print lookup_SNP(\%tbl_HoHoA, \%fastaHash, substr($splitLine[0],1), $splitLine[1], $splitLine[2], $splitLine[3], $splitLine[4], $splitLine[5], $splitLine[6]);
	}elsif (length($splitLine[3]) == length($splitLine[4]) and length($splitLine[3]) > 1){
		for (my $i = $splitLine[1]; $i <= $splitLine[2]; ++$i){
			unless (substr($splitLine[3],$i-$splitLine[1],1) eq substr($splitLine[4],$i-$splitLine[1],1)){#sometimes internal nucleotides are identical
				print "SNP_multiple\t";
				print lookup_SNP(\%tbl_HoHoA, \%fastaHash, substr($splitLine[0],1), $i, $splitLine[2], substr($splitLine[3],$i-$splitLine[1],1), substr($splitLine[4],$i-$splitLine[1],1), $splitLine[5], $splitLine[6]);
			}
		}
	}else{
		print "Structural\t";
		print lookup_SNP(\%tbl_HoHoA, \%fastaHash, substr($splitLine[0],1), $splitLine[1], $splitLine[2], $splitLine[3], $splitLine[4], $splitLine[5], $splitLine[6], 1);
	}
	
} 

close $FH_HCD;


sub lookup_SNP {
	
	my $hashRef = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $fastaHashRef = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $seqName = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $pos = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $endPos = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $ref = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $alt = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $depth = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $freq = shift @_ or die ("\nERROR: insufficient arguments to lookup_SNP subroutine\n\n");	
	my $structural = shift @_;
	
	my %hash = %$hashRef;
	my %fasta = %$fastaHashRef;
	my $returnLine;
	
	if ($structural){
		$returnLine = "$seqName\t$pos\t$endPos\t$ref\t$alt\t$depth\t$freq\t";
	}else{
		$returnLine = "$seqName\t$pos\t$pos\t$ref\t$alt\t$depth\t$freq\t";
	}
	
	if (defined $hash{$seqName}{'genic'}[$pos]){#note that for structural variants this is only considering teh first position
		$returnLine .= "genic\t".$hash{$seqName}{'type'}[$pos]."\t".$hash{$seqName}{'name'}[$pos]."\t".$hash{$seqName}{'strand'}[$pos]."\t" ;
		if (defined $hash{$seqName}{'exon'}[$pos]){
			$returnLine .= "exon\t".$hash{$seqName}{'genePos'}[$pos]."\t";
			if ($structural){
				$returnLine .= ".\t.\t.\t.\t.\t.\n";
			}
			elsif ($hash{$seqName}{'type'}[$pos] eq "CDS"){
				my $refCodon; 
				if ($hash{$seqName}{'strand'}[$pos] == 1){
					$refCodon = substr($fasta{$seqName},$pos - $hash{$seqName}{'codonPos'}[$pos],3);
				}elsif ($hash{$seqName}{'strand'}[$pos] == -1){
					$refCodon = revcom(substr($fasta{$seqName},$pos - 4 + $hash{$seqName}{'codonPos'}[$pos],3));
					$ref = revcom ($ref);
					$alt = revcom ($alt) ;
				}else{
					die ("\nERROR: improper strand encoding\n\n")
				}
				$ref eq substr ($refCodon, $hash{$seqName}{'codonPos'}[$pos]-1 , 1) or die ("\nStated refrence nucleotide does not match fasta\n\n");
				
				my $altCodon = $refCodon;
				substr ($altCodon, $hash{$seqName}{'codonPos'}[$pos]-1 , 1, $alt);
				my $refAA = codon2aa($refCodon);
				my $altAA = codon2aa($altCodon);
				my $syn;
				if ($refAA eq $altAA){
					$syn = "S";
				}else{
					$syn = "N";
				}
				$returnLine .= "$hash{$seqName}{'codonPos'}[$pos]\t$refCodon\t$altCodon\t$refAA\t$altAA\t$syn\n";
					
				
			}else{
				$returnLine .= ".\t.\t.\t.\t.\t.\n";
			}
		}else{
			$returnLine .= "intron\t.\t.\t.\t.\t.\t.\t.\n";
		}
				
	}else{
		$returnLine .= "intergenic\t.\t.\t.\t.\t.\t.\t.\t.\t.\t.\t.\n";
	}
	
	return $returnLine;
}

sub parse_tbl_file {
	#generate hash of hash of arrays.
	#top level key = genome fragment
	#second level key = annotation type (genic, integenic, tRNA, coding position, etc.)
	#arrays: length of the genome fragment. Populate corresponding nucleotide positions with annotation information.
	
	my $tblFile = shift @_ or die ("\nERROR: no filename provide to subroutine\n\n");
	my %HoHoA; #hash of hash of arrays to store annotation data
	my $FH_TBL = open_file($tblFile);
	my $seqName;
	my $activeGene = 0;
	my $geneName;
	#my $geneStart;
	#my $geneStop;
	my $geneType;
	my $lastStop;
	my $codon = 1;
	while (my $annot_line = <$FH_TBL>){#loop through tbl file
		$annot_line =~ /^\s+$/ and next; #skip blank lines;
		chomp $annot_line;
		if ($annot_line =~ /^>Features? (.+)/){#parse sequence name from header lines
			$seqName = $1;
			unless (exists $fastaHash{$seqName}){
				die ("\nERROR: Sequence name $seqName not recognized\n\n");
			}
			next;
		}
		$seqName or die ("\nERROR: Improper header format at beginning of tbl file.\n\n");
		my @splitLine = split (/\t/, $annot_line);
		defined $splitLine[2] and $splitLine[2] eq 'exon' and next;#skip exon lines
		if (defined $splitLine[3] and $splitLine[3] =~  /^(note|number|product)/){#skip note, exon number and product name lines. Reset placeholders.
			$activeGene = 0;
			$codon = 1;
			$lastStop = "";
			next;
		}	
		if ($annot_line =~ /^\d+\t\d+/){#lines starting with position coordinates
			my $lineStart = $splitLine[0];
			my $lineStop = $splitLine[1];
			if (defined $splitLine[2] and $splitLine[2] eq 'gene'){#for primary gene lines, store gene name and coords
				#$geneStart = $lineStart;
				#$geneStop = $lineStop;
				my $nextLine = <$FH_TBL>;
				chomp $nextLine;
				my @splitNextLine = split (/\t/, $nextLine);
				$splitNextLine[3] eq "gene" or die ("\nERROR: unexpected line after primary gene feature: $nextLine\n\n");
				$geneName = $splitNextLine[4];
				next;
			}else{
				if ($activeGene){#fill introns based on gaps between consecutive coordinate lines
					if ($lineStart > $lastStop){
						for (my $i = $lastStop+1; $i < $lineStart; ++$i){
							$HoHoA{$seqName}{"genic"}[$i] = 1;
							$HoHoA{$seqName}{"strand"}[$i] = 1;
							$HoHoA{$seqName}{"name"}[$i] = $geneName;
							$HoHoA{$seqName}{"type"}[$i] = $geneType;
						}
					}else{
						for (my $i = $lineStart+1; $i < $lastStop; ++$i){
							$HoHoA{$seqName}{"genic"}[$i] = 1;
							$HoHoA{$seqName}{"strand"}[$i] = -1;
							$HoHoA{$seqName}{"name"}[$i] = $geneName;
							$HoHoA{$seqName}{"type"}[$i] = $geneType;
						}						
					}
				}else{#if this is the first coordinate line, store gene type (CDS, rRNA, tRNA)
					$geneType = $splitLine[2];
					$activeGene = 1;
				}
				for (my $i = 0; $i <= abs($lineStart-$lineStop); ++$i){#loop through exon positions. 
					my $pos;
					if ($lineStart < $lineStop){
						$pos = $lineStart + $i; 
					}else{
						$pos = $lineStart - $i;
					}
					$HoHoA{$seqName}{"genic"}[$pos] = 1;
					$HoHoA{$seqName}{"name"}[$pos] = $geneName;
					$HoHoA{$seqName}{"type"}[$pos] = $geneType;
					$HoHoA{$seqName}{"exon"}[$pos] = 1;
					if ($lineStart < $lineStop){
						$HoHoA{$seqName}{"strand"}[$pos] = 1;
					}else{
						$HoHoA{$seqName}{"strand"}[$pos] = -1;
					}				
					if ($geneType eq 'CDS'){
						$HoHoA{$seqName}{"codonPos"}[$pos] = $codon;
						++$codon;
						if ($codon > 3){
							$codon = 1;
						}					
					}
					
				}
				$lastStop = $lineStop;
				
			}
		}else{
			die ("\nERROR: unrecognized tbl line: $annot_line\n\n");
		}	
	}
	
	close $FH_TBL;
	
	foreach my $fragment (sort keys %HoHoA){
		my %geneCounter;
		for (my $i = 1; $i <= scalar @{$HoHoA{$fragment}->{'name'}} ;++$i){
			if (defined $HoHoA{$fragment}{'name'}[$i] && defined $HoHoA{$fragment}{'exon'}[$i] && $HoHoA{$fragment}{'exon'}[$i] == 1 && $HoHoA{$fragment}{'strand'}[$i] == 1){
				++$geneCounter{$HoHoA{$fragment}{'name'}[$i]};
				$HoHoA{$fragment}{'genePos'}[$i] = $geneCounter{$HoHoA{$fragment}{'name'}[$i]};
			}
		}
		for (my $i = scalar @{$HoHoA{$fragment}->{'name'}}; $i >= 1 ;--$i){
			if (defined $HoHoA{$fragment}{'name'}[$i] && defined $HoHoA{$fragment}{'exon'}[$i] && $HoHoA{$fragment}{'exon'}[$i] == 1 && $HoHoA{$fragment}{'strand'}[$i] == -1){
				++$geneCounter{$HoHoA{$fragment}{'name'}[$i]};
				$HoHoA{$fragment}{'genePos'}[$i] = $geneCounter{$HoHoA{$fragment}{'name'}[$i]};
			}
		}
	}
	
	return %HoHoA;

}


sub arrays2hash {
	use strict;
	use warnings;

	(my $keyarray, my $valuearray) = @_;
	if (scalar(@$keyarray) != scalar(@$valuearray)) {
		die "Arrays differ in size: Mismatched number of keys and values"; 
	}
	
	my %newhash = ( );
	
	@newhash{ @$keyarray } = @$valuearray;


	return (%newhash);

}


sub get_fasta_names_and_seqs {
	use strict;
	use warnings;

	my ($inputfilename) = @_;
	my @fasta_names = ();
	my @fasta_seqs= ();

		   
	unless ( open(FILEDATA, $inputfilename) ) {
		print STDERR "Cannot open file \"$inputfilename\"\n\n"; #print error message
		exit; #exit the program
	}	

	my @filedata = <FILEDATA>; #Read the lines of the file into an array
	close FILEDATA;
	
	my $seq_count = 0; #this will be used to keep track of the number of sequences
	foreach my $line (@filedata){
		chomp $line;
		if ($line =~ /^\s*$/) {next;} #ignore line if it is blank
		
		elsif ($line =~ /^>/) { #if the line is a header line (begins with ">")...
			if ($line =~ /^>.*[\w]+/){
				my $partialLine = substr ($&, 1);
				push (@fasta_names, $partialLine); #add that line to an array of fasta names
				push (@fasta_seqs, ""); #and add a new blank element to an array of sequences
				++$seq_count; #also increment our counter which keeps track of sequence number
			}
		}	
		
		else { #if the line's not blank or a header, add it to the current sequence 
			$fasta_seqs[$seq_count-1] .= $line;
		}
		
		$fasta_seqs[$seq_count-1] =~s/\s//g; #remove all whitespace from the current  sequence
	}
	
	return (\@fasta_names, \@fasta_seqs);

}


sub open_file {
	use strict;
	use warnings;

    my($filename) = @_;
    my $fh;

    unless(open($fh, $filename)) {
        print "Cannot open file $filename\n";
        exit;
    }
    return $fh;
}


sub codon2aa {
	use strict;
	use warnings;

    my($codon) = @_;

    $codon = uc $codon;
 
    my(%genetic_code) = (
    
    'TCA' => 'S',    # Serine
    'TCC' => 'S',    # Serine
    'TCG' => 'S',    # Serine
    'TCT' => 'S',    # Serine
    'TTC' => 'F',    # Phenylalanine
    'TTT' => 'F',    # Phenylalanine
    'TTA' => 'L',    # Leucine
    'TTG' => 'L',    # Leucine
    'TAC' => 'Y',    # Tyrosine
    'TAT' => 'Y',    # Tyrosine
    'TAA' => '*',    # Stop
    'TAG' => '*',    # Stop
    'TGC' => 'C',    # Cysteine
    'TGT' => 'C',    # Cysteine
    'TGA' => '*',    # Stop
    'TGG' => 'W',    # Tryptophan
    'CTA' => 'L',    # Leucine
    'CTC' => 'L',    # Leucine
    'CTG' => 'L',    # Leucine
    'CTT' => 'L',    # Leucine
    'CCA' => 'P',    # Proline
    'CCC' => 'P',    # Proline
    'CCG' => 'P',    # Proline
    'CCT' => 'P',    # Proline
    'CAC' => 'H',    # Histidine
    'CAT' => 'H',    # Histidine
    'CAA' => 'Q',    # Glutamine
    'CAG' => 'Q',    # Glutamine
    'CGA' => 'R',    # Arginine
    'CGC' => 'R',    # Arginine
    'CGG' => 'R',    # Arginine
    'CGT' => 'R',    # Arginine
    'ATA' => 'I',    # Isoleucine
    'ATC' => 'I',    # Isoleucine
    'ATT' => 'I',    # Isoleucine
    'ATG' => 'M',    # Methionine
    'ACA' => 'T',    # Threonine
    'ACC' => 'T',    # Threonine
    'ACG' => 'T',    # Threonine
    'ACT' => 'T',    # Threonine
    'AAC' => 'N',    # Asparagine
    'AAT' => 'N',    # Asparagine
    'AAA' => 'K',    # Lysine
    'AAG' => 'K',    # Lysine
    'AGC' => 'S',    # Serine
    'AGT' => 'S',    # Serine
    'AGA' => 'R',    # Arginine
    'AGG' => 'R',    # Arginine
    'GTA' => 'V',    # Valine
    'GTC' => 'V',    # Valine
    'GTG' => 'V',    # Valine
    'GTT' => 'V',    # Valine
    'GCA' => 'A',    # Alanine
    'GCC' => 'A',    # Alanine
    'GCG' => 'A',    # Alanine
    'GCT' => 'A',    # Alanine
    'GAC' => 'D',    # Aspartic Acid
    'GAT' => 'D',    # Aspartic Acid
    'GAA' => 'E',    # Glutamic Acid
    'GAG' => 'E',    # Glutamic Acid
    'GGA' => 'G',    # Glycine
    'GGC' => 'G',    # Glycine
    'GGG' => 'G',    # Glycine
    'GGT' => 'G',    # Glycine
    '---' => '-',    # gap
    );

    if(exists $genetic_code{$codon}) {
        return $genetic_code{$codon};
    }else{
            return "?";
    }
}


sub revcom {
	use strict;
	use warnings;

    my($dna) = @_;

    # First reverse the sequence
    my $revcom = reverse $dna;

    # Next, complement the sequence, dealing with upper and lower case
    # A->T, T->A, C->G, G->C, etc.
    $revcom =~ tr/53ACGTUMRWSYKVHDBNacgtumrwsykvhdbn/35TGCAAKYWSRMBDHVNtgcaakywsrmbdhvn/;

    return $revcom;
}