#!/usr/bin/perl

# Author: April Hussey <ahussey@umd.edu>
# Created: 08-26-08
# Last Revised: 05-14-09
# Version: 1.2
#
# Copyright (C) 2008, 2009  April Hussey
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# Latest versions of Degen1 script and documentation are available at 
# http://www.phylotools.com
#
###########################################################################
#
# First published in Nature (2010) as Supplementary Information. 
# Title: Arthropod relationships revealed by phylogenomic analysis 
#        of nuclear protein-coding sequences"
# Authors: Regier, J.C., Shultz, J.W., Zwick, A., Ball, B., Hussey, A., 
#          Wetzer, R., Martin, J.W., and Cunningham, C.W.
#
# Requirements:
#   - functional PERL installation
#     (tested with v5.10.0 built for x86_64-linux-gnu-thread-multi)
#     (tested with v5.10.0 built for MSWin32-x86-multi-thread)
#     (tested with v5.8.6 built for darwin-thread-multi-level, OS X 10.4.11)
#   - input file in FASTA or FLAT format
#
# To execute this script, type on the command line:
#   perl degen1_v1_2.pl infile.fasta
#                OR
#   perl degen1_v1_2.pl infile.flat
#
# The original input file will not be overwritten.
# Output directory, Degen1_<basefilename>, is created in the directory from which the script is run and contains 3 output files:
#   Degen1_<basefilename>.FASTA - the final dataset of the transformed nucleotide sequences in multi-fasta format
#   HashRegEx1_<basefilename>.txt - the complete listing of all nucleotide positions transformed by the script
#   Warnings1_<basefilename>.txt - the complete listing of all nucleotide positions not transformed by the script and warnings about unexpected sequence lengths or characters
#   Positions noted in the files are of the first base of the codon mentioned
# Triplets that encode Leu or Leu & Phe are converted to YTN
# Triplets that encode Arg or Arg & Ser2 are converted to MGN
# Triplets that encode His & Gln, Asn & Lys, or Asp & Glu are converted to CAN, AAN, or GAN, respectively
# Other triplets that encode nonsynonymous polymorphisms at nt1 and/or nt2 are converted to NNN
#
###########################################################################

%degencodons = (
                 YTN => [qw(TTM TTK TTS TTW TTH TTB TTV TTD TTN TTA TTG TTR CTA CTC CTG CTT CTR CTY CTM CTK CTS
                            CTW CTH CTB CTV CTD CTN YTC YTA YTT YTG YTR YTY YTM YTK YTS YTW YTH YTB YTV YTD YTN)], # Leu, Phe & Leu
                 TTY => [qw(TTT TTC TTY)], # Phe
                 MGN => [qw(CGT CGA CGC CGG CGR CGY CGM CGK CGS CGW CGH CGB CGV CGD CGN AGA AGG AGR AGM AGK AGS
                            AGW AGH AGB AGV AGD AGN MGC MGA MGT MGG MGR MGY MGM MGK MGS MGW MGH MGB MGV MGD MGN)], # Arg, Arg & Ser2
                 ATH => [qw(ATT ATC ATA ATH ATY ATM ATW)], # Ile
                 ATN => [qw(ATR ATK ATS ATB ATV ATD ATN)], # Ile & Met
                 ATG => [qw(ATG)], # Met
                 GTN => [qw(GTT GTA GTC GTG GTR GTY GTM GTK GTS GTW GTH GTB GTV GTD GTN)], # Val
                 TCN => [qw(TCT TCA TCC TCG TCR TCY TCM TCK TCS TCW TCH TCB TCV TCD TCN)], # Ser1
                 AGY => [qw(AGT AGC AGY)], # Ser2
                 CCN => [qw(CCT CCA CCC CCG CCR CCY CCM CCK CCS CCW CCH CCB CCV CCD CCN)], # Pro
                 ACN => [qw(ACT ACA ACC ACG ACR ACY ACM ACK ACS ACW ACH ACB ACV ACD ACN)], # Thr
                 GCN => [qw(GCT GCA GCC GCG GCR GCY GCM GCK GCS GCW GCH GCB GCV GCD GCN)], # Ala
                 TAY => [qw(TAT TAC TAY)], # Tyr
                 CAY => [qw(CAT CAC CAY)], # His
                 CAN => [qw(CAM CAK CAS CAW CAH CAB CAV CAD CAN)], # His & Gln
                 CAR => [qw(CAA CAG CAR)], # Gln
                 AAY => [qw(AAT AAC AAY)], # Asn
                 AAN => [qw(AAM AAK AAS AAW AAH AAB AAV AAD AAN)], # Asn & Lys
                 AAR => [qw(AAA AAG AAR)], # Lys
                 GAY => [qw(GAT GAC GAY)], # Asp
                 GAN => [qw(GAM GAK GAS GAW GAH GAB GAV GAD GAN)], # Asp & Glu
                 GAR => [qw(GAA GAG GAR)], # Glu
                 TGY => [qw(TGT TGC TGY)], # Cys
                 TGB => [qw(TGK TGS TGB)], # Cys & Trp
                 TGG => [qw(TGG)], # Trp
                 GGN => [qw(GGT GGA GGC GGG GGR GGY GGM GGK GGS GGW GGH GGB GGV GGD GGN)], # Gly
                 NNN => [qw(NNN)], # degen
                 '---' => [qw(---)], # indel
               );

# print "key (array), element (key)" for each element in the hash
foreach $codonkey (keys %degencodons)
  {
    @codonarray = @{$degencodons{$codonkey}};
#    print "@codonarray, $codonkey\n";
    foreach $codon (@codonarray)
      {
        if (exists $degencodons1by1{$codon})
          {
            $Warnings .= "codon ($codon) already exists as a key\n";
            print "codon ($codon) already exists as a key\n";
          }
        $degencodons1by1{$codon}=$codonkey;
      }
  }

###########################################################################

# $ARGV[0] holds <filename> (a multi-fasta or flat file)
# Store file contents in an array
open(INPUT, "$ARGV[0]");
@FileContents = <INPUT>;
close(INPUT);

# Remove ending from input filename
$filename = $ARGV[0];
$filename =~ s/(\..*?$)//;

# Create a directory for the output files, then enter that directory
mkdir("Degen1_$filename", 0755);
chdir("Degen1_$filename");

# Join the array into a single string
$ConcatContents = join('', @FileContents);

# Split the string at the #s or >s and store each remaining fragment as an item in a new array
@AllSequences = split(/[#>]/, $ConcatContents);

# Remove the 1st blank item in the array (preceding the 1st > or #)
shift(@AllSequences);

###########################################################################

# Find highlighted codons in each sequence
foreach $Consensus (@AllSequences)
  {
    # Remove sequence names and end of line characters
    $Consensus =~ s/^(.*?)(\r?\n|\r)//;
    $DegenSeq .= "\n\>$1\n";
    $SequenceName = $1;
    $Consensus =~ s/\s//sg;

    # Find the length of the sequences (they should all be the same length)
    $ConsensusLength = length($Consensus);
    $Warnings .= "Sequence: $SequenceName, $ConsensusLength bp\n";
    $HashRegExWarnings .= "Sequence: $SequenceName, $ConsensusLength bp\n";
    print "Sequence: $SequenceName, $ConsensusLength bp\n";

    # replace all ?s in the sequence with Ns
    $Consensus =~ s/\?/N/g;

    # verify that the sequence ends with a complete codon - the sequence length should be evenly divisible by 3
    if ($ConsensusLength%3 != 0)
      {
        # write error to error log file
        $Warnings .= "Warning: Sequence ($SequenceName, $ConsensusLength bp) is not in the first reading frame or does not end with a complete codon\n";
        print "Warning: Sequence ($SequenceName, $ConsensusLength bp) is not in the first reading frame or does not end with a complete codon\n";
      }

  # Jump through the sequence and check each codon
  for($Position = 0; $Position < $ConsensusLength; $Position += 3)
    {
      # Extract the codon at the current position as upper case characters from the sequence
      $codon1 = uc substr($Consensus, $Position, 3);
      # Compare the codon to our lists (in a hash) and find the degenerate codon with which to replace it
      if (exists $degencodons1by1{$codon1})
        {
          $DegenSeq .= "$degencodons1by1{$codon1}";
          $HashRegExWarnings .= "hash: $codon1 replaced with $degencodons1by1{$codon1} at position $Position\n";
          print "hash: $codon1 replaced with $degencodons1by1{$codon1} at position $Position\n";
        }
      elsif ($codon1 =~ m/([^-][RYMKSWHBVDN]|[RYMKSWHBVDN][^-])([^-])/i)
        {
          # if nt1 and/or nt2 are/is degenerate, the codon becomes NNN
          $HashRegExWarnings .= "regex1: $codon1 replaced with ";
          print "regex1: $codon1 replaced with ";
          $codon1 =~ s/([^-][RYMKSWHBVDN]|[RYMKSWHBVDN][^-])(.)/NNN/i;
          $DegenSeq .= "$codon1";
          $HashRegExWarnings .= "$codon1 at position $Position\n";
          print "$codon1 at position $Position\n";
        }
      else
        {
          $Warnings .= "Warning: Codon ($codon1, $Position) not changed\n";
          print "Warning: Codon ($codon1, $Position) not changed\n";
          $DegenSeq .= "$codon1";
        }
    }
    print "\n<--*-->\n";
  }

# Remove first blank line
$DegenSeq =~ s/^\n//;

print "\nDegenerate Sequences:\n$DegenSeq\n";

###########################################################################

# New fasta file with degenerate sequences
open(DEGEN, ">Degen1_$filename.FASTA");
print DEGEN $DegenSeq;
close(DEGEN);

# New warning output file
open(WARN, ">Warnings1_$filename.txt");
print WARN $Warnings;
close (WARN);

# New hash/regex output file
open(HASHRE, ">HashRegEx1_$filename.txt");
print HASHRE $HashRegExWarnings;
close (HASHRE);