#! /usr/bin/perl

# Script to process Kellogg OTU data.  Lists of unique OTUs are printed to the screen.
#
# This script is tailored to run under Apple's Mac operating system.
# If running under another OS, specify the appropriate end-of-line character in
# line #40.
#
# Dave Zawada, Ph.D.
# U.S. Geological Survey
# St. Petersburg Coastal and Marine Science Center
# 600 4th Street South
# St. Petersburg, Florida 33701
#
# 13 January 2011
#
# 10 May 2013:  Fixed bug in the search for OTUs exclusive to PoolA & PoolB, respectively


if ($#ARGV < 0)
{
	print "\n\tPlease specify the OTU database (CSV format).\n";
	print "Lists of unique OTUs are printed to the screen.\n";
	exit -1;
}

#=============================
#===== Subroutine declarations
#=============================
sub print_menu;
#-----------------------------------------------------------------------------------


#=============================
#===== MAIN
#=============================
#
# Macs use caridge returns as EOL designators, not newlines,
# so set PERL's input line separator variable to a caridge return for
# reading the file.
#
$/ ="\r";


# Open and read the specified *.csv file
#
open FIL, $ARGV[0];
@data =<FIL>;
close FIL;


# Parse the header
#
$tmp =$data[0];  chop $tmp;
@hdr =split(/\,/, $tmp);


# Organize the data into hashes to facilitate searches
#
%S =();  # Hash table containing a vector of OTUs for each sample

print "Process ", $#data, " records.  This may take a while...\n\n";

for($i=1; $i<=$#data; $i++)
{
	# Split the current data line into separate fields
	#
	@ln =split(/\,/, $data[$i]);

	# Loop through fields (samples) in @ln and add the current OTU to each
	# sample in which it is present.
	#
	for($j=1; $j<=$#ln; $j++)
	{
		# Skip to next sample if current OTU is not present
		#
		if ($ln[$j] == 0)  { next; }

		# Append the current OTU to this sample
		#
		@tmp =@{$S{$hdr[$j]}};
		push(@tmp, $ln[0]);

		$S{$hdr[$j]} =[@tmp];
	}
}

# Sort the list of sample names
#
@sampnames =sort(keys(%S));


# print "Available samples\n--------------------\n";
# for($i=0; $i<=$#sampnames; $i++)
# {
# 	printf("%3d\.  %s\n", $i+1,$sampnames[$i]);
# }


# Change the input line separator back to a newline so we can
# read user input from the command line.
#
$/ ="\n";


while (1)
{
	print_menu();

	# Get list of samples to compare
	#
	print "\n\nEnter the samples for Group_A (comma-separated list of index #s) or 0 to exit\n";
	$tmp =<STDIN>;  chop $tmp;
	
	if ($tmp == 0)  {last;}

	@ga =split(/\,/, $tmp);  # Index #s for Group_A
	
	print "Enter the samples for Group_B (comma-separated list of index #s) or 0 to exit\n";
	$tmp =<STDIN>;  chop $tmp;
	
	if ($tmp == 0)  {last;}
	
	@gb =split(/\,/, $tmp);  # Index #s for Group_B



	# OK, if we get this far, then the user really wants to do the comparisons
	#

	# Create OTU pools for each group
	#
	# POOL A
	$poola ='';  %OcountsA =();
	%OA =();  # Hash table containing a vector of samples associated with each OTU

	for($i=0; $i<=$#ga; $i++)
	{
		$samp =$sampnames[$ga[$i]-1];  # subtract 1 from each $ga be/c PERL is 0-referenced

		@otus =@{$S{$samp}};
		for($o=0; $o<=$#otus; $o++)
		{
			# Append the current sample to each OTU's list
			#
			@tmp =@{$OA{$otus[$o]}};
			push(@tmp, $samp);
			$OA{$otus[$o]} =[@tmp];

			if ($poola =~ /\,$otus[$o]\,/)
			{
				$OcountsA{$otus[$o]} =$OcountsA{$otus[$o]} + 1;
				next;
			}
			
			$poola ="$poola,$otus[$o]";
			$OcountsA{$otus[$o]} =1;
		}
	}  # END:  for - group A

	$poola ="$poola,";  # Make sure all OTUs are bracketed by ',' so we can use regex text search for unique values
	$poola =~ /^\,(.*)\,$/;
	@poola =split(/\,/, $1);  # Contains just OTUs; no empty entries, i.e. ''


	# POOL B
	$poolb ='';  %OcountsB =();  @tmp =();
	%OB =();  # Hash containing a vector of samples associated with each OTU

	for($i=0; $i<=$#gb; $i++)
	{
		$samp =$sampnames[$gb[$i]-1];  # subtract 1 from each $ga be/c PERL is 0-referenced

		@otus =@{$S{$samp}};
		for($o=0; $o<=$#otus; $o++)
		{
			# Append the current sample to each OTU's list
			#
			@tmp =@{$OB{$otus[$o]}};
			push(@tmp, $samp);
			$OB{$otus[$o]} =[@tmp];

			if ($poolb =~ /\,$otus[$o]\,/)
			{
				$OcountsB{$otus[$o]} =$OcountsB{$otus[$o]} + 1;
				next;
			}
			
			$poolb ="$poolb,$otus[$o]";
			$OcountsB{$otus[$o]} =1;
		}
	}  # END:  for - group B

	$poolb="$poolb,";  # Make sure all OTUs are bracketed by ',' so we can use regex text search for unique values
	$poolb =~ /^\,(.*)\,$/;
	@poolb =split(/\,/, $1);  # Contains just OTUs; no empty entries, i.e. ''


	# Now, compile uniqueness info...
	#
	# (1) Find OTUs unique to each group
	#
	@ua =();  @ub =();
	
	for($i=0; $i<=$#poola; $i++)
	{
		if ($poolb !~ /\,$poola[$i]\,/)  # Regex text search to find unique OTUs in poolA
		{
			push(@ua, $poola[$i]);
		};
	}
	print "\n\nUnique Group A OTUs\n-------------------\n";
	for($i=0; $i<=$#ua; $i++)
	{
		printf "%7d) %7d ::", $i+1,$ua[$i];
		
		foreach $s (@{$OA{$ua[$i]}})
		{
			printf " %s", $s;
		}
		print "\n";
	}
	print "\n";



	for($i=0; $i<=$#poolb; $i++)
	{
		if ($poola !~ /\,$poolb[$i]\,/)  {push(@ub, $poolb[$i])};
	}
	print "\n\nUnique Group B OTUs\n-------------------\n";
	for($i=0; $i<=$#ub; $i++)
	{
		printf "%7d) %7d ::", $i+1,$ub[$i];
		
		foreach $s (@{$OB{$ub[$i]}})
		{
			printf " %s", $s;
		}
		print "\n";
	}
	print "\n";
}  # END:  while


#===================================================
#===== SUBROUTINES
#===================================================
sub print_menu
{
	print "\n**************************************************\n\nAvailable samples\n------------------\n";
	for($i=0; $i<=$#sampnames; $i++)
	{
		printf("%3d\.  %s\n", $i+1,$sampnames[$i]);
	}
	
	return(0);
}
#------------------------------------------------------------------------------


exit 0;

