#!/usr/bin/perl -w
#
# CD_identification.cgi
#
# ============================================================================
# An experimental script to try to define Brassica/Arabidopsis
# breakpoints by examining associations between chromosome bins from
# atidb_v6 on the basis of orphaned KBr* BACend mappings with shared root names
# Realised that, in essence, graphical display reduces to a GridMap problem!
#
# Copyright (C) 2006 Martin Trick
#
#    This library is free software; you can redistribute it and/or
#    modify it under the terms of the GNU Lesser General Public
#    License as published by the Free Software Foundation; either
#    version 2.1 of the License, or (at your option) any later version.
#
#    This library 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
#    Lesser General Public License for more details.
#
#    You should have received a copy of the GNU Lesser General Public
#    License along with this library; if not, write to the Free Software
#    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
#    Copy included as file 'lgpl.txt' in this distribution
#
# =============================================================================
# Revision history
#
# CGI version v0.1
# Martin.Trick@bbsrc.ac.uk 30/3/2006
#
# v0.2
# Code to suppress noise from repeats and to make GridMap symmetrical
# (symmetry across leading diagonal was being destroyed by the noise
# suppression code) - this was deprecated and removed!
#
# v0.3
# Realised noise lines were coming from orphans being mapped within the
# *same* bin (coming from size/strand inconsistency). This compromised the
# set union/intersection routine. Now we check and don't push duplicates
# of a clone name into the array for any given bin.
#
# Martin.Trick@bbsrc.ac.uk 7/7/2006
#
# v0.4
# Added heuristic filtering code, selected as a user option, which examines
# the list of candidate clones and identifies best ones on basis of strand
# disposition and endpoints. Can't track down source of instability - script
# occasionally grinds very slowly, but can be relieved by MySQL restart
#
# Martin.Trick@bbsrc.ac.uk 2/8/2006
#
# v0.5
# Big speedup achieved through doing only the maximum number of Chr x Chr
# comparisons  required if we exploit symmetry around the leading diagonal.
# Also created new heuristic processing rule to ignore adjacent bins if
# binsize is small
#
# Martin.Trick@bbsrc.ac.uk 10/8/2006
#
# v0.6
# Changed the code for identifying adjacent genes. Now that gff_v2.pl includes
# alternative mappings, GFF.pm was throwing a multiple segments exception
# as $db->segment was being called in scalar context. We now define the
# starting segment uniquely by refseq and absolute coordinates
#
# Martin.Trick@bbsrc.ac.uk 10/10/2006
#
# v0.7
# Reinstated some tweaks that were lost. Fixed a presumably
# long standing problem in the segment expansion code to locate gene neighbours.
# Changed $feature_type to @feature_types to accommmodate multiple types and
# added appropriate changes to handling code, commented as ####
#
# Martin.Trick@bbsrc.ac.uk 7/4/2008
#
# v0.8
# Added code to check for inconsistencies between chr BLAST hits and hits vs
# AGI gene models (loaded as a separate file). Comes in two flavours; 'weak'
# simply  checks for a conflict between the top hits from the two methods and
# eliminates  such clones. 'Strong' consults the top gene hits and looks for a
# combination  that would be within microsynteny range. Each method has its
# benefits.
# Also added little tweak to spreadsheet code to print reads in AGI code order
# Also fixed strand disposition code: 5+::5- is now ordered by gene model number
#
# Martin.Trick@bbsrc.ac.uk 22/4/2008
#
#
# ========================================================================

# Load modules
use CGI qw(:standard);
use Bio::DB::GFF;
use FileHandle;
use Spreadsheet::WriteExcel;

my $run = new CGI;
print $run->header;

# Make the client's main browser window return to the parent page

# NB. This meta refresh js: method has been closed off in Firefox 3.09 (and
# never worked for IE). So, execute in body of document instead
#print $query->start_html(-head=>meta({-http_equiv => 'Refresh',
#                                     -content => '0; URL=javascript:history.back()'}),

print $run->start_html(-noScript => '<H2>For this feature, you need to enable
Java and Javascript and to permit popups from this site</H2>');
print $run->end_html;


# Pick up CGI form params
my $identity = $run->param('identity') || 80; # Cutoff for feature identity score
my $binsize = $run->param('binsize') || 100000; # Chr bin size, increases res
my $min = $run->param('min') || 2; # Threshold for no. of clones shared between bins
my $max = $run->param('max') || 10; # Don't think this is a sensitive param
my $microsynteny = $run->param('microsynteny'); # Threshold for bin separation
my $output_file = "/var/www/html/tmp/gridmap.$$";
my $filter = $run->param('filter') || 0; # Heuristic filtering code option
my $state = ($filter) ? 'on' : 'off';
my $paralogue_cleanup = $run->param('paralogue_cleanup');

# Other variables
my $spreadsheet = "/var/www/html/tmp/sniffer.$$.xls";
my $log = $run->param('log') || 0; # Verbose logging of filtering process
my $logfile = "/var/www/html/tmp/sniffer.$$.txt";
my $gene_list = '/var/www/html/tmp/gene_hits.txt '; # Source of AGI gene BLAST data, new from v0.8
my $host_url = 'http://xxxxxxx';

# Check for coupled options
if (!$filter) {$log = 0; }

# The GFF feature type and classes to use
my @feature_types = ('BlastN:KBr-BACend', 'BlastN:Bo-BACend');
my @classes = ('KBr-BACend', 'Bo-BACend');

# Parameter for eliminating pileups of coincident features
my $pileup = 3;
# Incremental segment window for locating genes
my $gene_window = 1000;
# Max iterations for locating genes
my $gene_iterations = 5; # 5
# Clone endpoint window for filtering
my $end_window = 200000;
# Physical separation allowed in gene neighbours returned by chr and AGI gene BLASTs
my $gene_tolerance = 5000;

# HTML for status popup window
my $style = qq(<FONT STYLE="font-family: Verdana,Arial,Helvetica,sans-serif; font-size: 7pt">);
my $button = qq(<INPUT style="font-family: Verdana,Arial,Helvetica,sans-serif; font-size: 7pt"; TYPE="button" VALUE="Close Applet window" onClick="self.close();"></HTML>);
my $applet = qq(<APPLET CODEBASE="http://$host_url/Java" CODE="uk/ac/CropNet/GridMaker/GridApplet.class");
$applet .= qq(ARCHIVE="uk/ac/CropNet/GridMaker/GridMap.jar" WIDTH="0" HEIGHT="0" HSPACE="0" VSPACE="0" ALIGN="middle">);
$applet .= qq(<PARAM NAME="DataFile" VALUE="$host_url/tmp/gridmap.$$"></APPLET>);
my $spreadsheet_url = qq(Filtered results in spreadsheet format <A HREF="http://$host_url/tmp/sniffer.$$.xls" TARGET="_new">here</A><BR>);
my $log_url = qq(Log of filtering process <A HREF="$host_url/tmp/sniffer.$$.txt" TARGET="_new">here</A><BR>);

# Attributes for the GridMap display
my $grid_title = "CD analysis";
my $axis_title = "Arabidopsis chromosome\nArabidopsis chromosome";
my $scale_factor = 0.003; # 3 pixels to 1 kb

# Initialise spreadsheet object, if heuristic filter code is on
my $workbook;
if ($filter) {
  $workbook = Spreadsheet::WriteExcel->new("$spreadsheet") or die "Couldn't open spreadsheet file ($!) \n";
  init_spreadsheet(\$workbook);
}

# Hash of arrays for the map information
my %binData = ();
# Hash of arrays for AGI gene BLAST hits
my %genes = ();

# Open the GFF database
my $db = Bio::DB::GFF->new( 	-adaptor => 'dbi::mysqlopt',
                            	-dsn     => 'dbi:mysql:atidb',
				-user    => 'root',
				-pass    => 'XXXXXX',
				-fasta   => '/usr/local/databases/gbrowse-gff/atidb/fasta/atidb_genome_v5.fasta'
			  ) or die;


# Start building the GridMap datafile
open (OUT, ">$output_file") or die "Couldn't open file $output_file\n";
print OUT "\/\/\*\*\*GRID TITLE\*\*\*\n$grid_title\n\/\/\*\*\*END\n\n";
print OUT "\/\/\*\*\*AXIS TITLE\*\*\*\n$axis_title\n\/\/\*\*\*END\n\n";
print OUT "\/\/\*\*\*GRID DATA\*\*\*\n";

STDOUT->autoflush(1);
&init_popup;

# Read in the AGI gene BLAST data
open (LIST, "<$gene_list") or die "Couldn't open gene BLAST file\n";
while (<LIST>) {
  my ($bacend, @list) = split;
  push @{$genes{$bacend}}, @list;
  #print popup("seen $bacend <Br>") if $test{$bacend}++;
}
close LIST;

print popup("<title>working...</title>");
print popup($style);
print popup("Extracting data...<BR>");


# Scan the GFF DB by chromosome and by bin
for (my $ref = 1; $ref <= 5; $ref++) {
  print popup("Scanning chromosome $ref");
  # Define chromosome segment
  my $chromosome = $db->segment(-name=>$ref);
  my $length = $chromosome->length;
  print popup(" (length $length bp)<BR>");
  # Scale the GridMap
  my $scaled_length = $length*$scale_factor;
  for my $axis (0..1) {
    print OUT "$ref|$axis|$scaled_length\n";
  }
  my $bin = 0;
  for (my $start = 0; $start < ($length - $binsize); $start += $binsize) {
    $bin++;
    my $stop = $start + $binsize;
    # Create a new subsegment object for this chr bin
    my $segment = $chromosome->subseq($start,$stop);
    if (defined $segment) {
      # Extract list of features and push into hashed array structure
      #my @features = $segment->features(-types => $feature_type);
      my @features = $segment->features(-types =>\@feature_types); ####
      my %pileup = (); # Hash to record pileups on same start coordinate
      my %seen = (); # Hash to record clone names in this bin
    FEATURE: foreach my $feature (@features) {
	if ($feature->score < $identity || $pileup{$feature->start}++ > $pileup) { next FEATURE;}
	# Extract the clone name
	#my ($clone) = $feature->name =~ /(KBr[HBS]\d{3}\w\d{2})_[FR]/;
	my ($clone) = $feature->name =~ /(\w+)_[FR]/; ####
	# Don't push this clone name again (i.e. if both ends mapped to same bin)
	push @{$binData{$ref}{$bin}}, $clone unless ($seen{$clone}++);
      }
    }
  }
}
# Now all the clone incidences are stored in the %binData hash of arrays

print OUT "\/\/\*\*\*END\n\n";
print OUT "\/\/\*\*\*DATA POINTS\*\*\*\n";
print popup("Processing data (filter $state");
if ($filter) {print popup("; paralogue cleanup $paralogue_cleanup"); }
print popup(")...<BR>");

# The sum of the key values of %binData is the maximum number of chr x chr
# comparisons that we need if we exploit symmetry around the leading diagonal
my $comparisons;
foreach my $key (keys %binData) {
  $comparisons += $key;
}
# A simple progress meter
print popup("0%");
for my $point (2..$comparisons) {
  print popup("&nbsp;&nbsp;");
}
print popup("100%<BR>&nbsp;&nbsp;");

# Assemble provisional homology data by going through the hashed arrays twice, keyed by
# chr and bin, hence we have four nested loops. We reduce the range of the $ref_y loop
# each time, using the value of $ref_x as the start, because we're using symmetry
foreach my $ref_x (sort keys %binData) {
  for my $ref_y ($ref_x..scalar(keys %binData)) {
    print popup("&nbsp;."); # Use &#930 instead for diamond symbol
  X: foreach my $bin_x (sort {$a <=> $b} keys  %{ $binData{$ref_x}}) {
      my $pos_x = $bin_x * $binsize * $scale_factor;
    Y: foreach my $bin_y (sort {$a <=> $b} keys  %{ $binData{$ref_y}}) {
	# Special treatment for the intrachromosome comparisons
	if ($ref_x == $ref_y) {
	  next Y if ($bin_y >= $bin_x); # Suppresses leading diagonal and exploits symmetry
	  next Y if (abs($bin_y - $bin_x)*$binsize <= $microsynteny); # Exclude adjacent bins if binsize ~ microsynteny
	}
	my $pos_y = $bin_y * $binsize * $scale_factor;
	my $clones = '';
	# A set union/intersection routine, straight from the Bighorn book
	my @union = my @intersect = ();
	my %union = my %intersect = ();
	foreach my $e (@{$binData{$ref_x}{$bin_x}}, @{$binData{$ref_y}{$bin_y}}) {
	  $union{$e}++ && $intersect{$e}++;
	}
	@intersect = keys %intersect or next Y;
	if (@intersect < $min) {next Y; }
	# If this option is selected, filter @intersect array according to some Clever Rules
	my @filtered = ($filter)?(filter(\@intersect,$ref_x,$ref_y,$bin_x,$bin_y)):(@intersect);
	if (@filtered >= $min && @filtered <= $max){
	  foreach my $e(@filtered) {$clones .= "$e, "; }
	  print OUT "Chr$ref_x" . "Bin$bin_x" . "::" . "Chr$ref_y" . "Bin$bin_y" . " (" . scalar(@filtered) . ") {$clones}" . "|$ref_x| |$pos_x|0|$ref_y| |$pos_y|0| | | |\n";
	  # Print out the mirror image point
	  print OUT "Chr$ref_y" . "Bin$bin_y" . "::" . "Chr$ref_x" . "Bin$bin_x" . " (" . scalar(@filtered) . ") {$clones}" . "|$ref_y| |$pos_y|0|$ref_x| |$pos_x|0| | | |\n";
	}
      }
    }
  }
}

# Close the GridMap file
print OUT "\/\/\*\*\*END\n\n";
print OUT "\/\/\*\*\*END OF FILE\n";
close OUT;
$workbook->close if $filter;

# Write applet code and URLs to popup
print popup("&nbsp;&nbsp;done<BR>");
print popup($spreadsheet_url) if $filter;
print popup($log_url) if $log;
print popup($applet);
print popup($button);
print "<SCRIPT>window.location.replace=history.go(-1)</SCRIPT>";
print $run->end_html;

# The end of the script as we know it

sub init_popup {
print <<SCRIPT;
<SCRIPT language=\"Javascript\">
var offset = screen.availHeight-335;
features = "width=300,height=170,left=0,top="+offset+",screenY="+offset;
features += ",titlebar=1,scrollbars=1";
var windowHandle = window.open('','popup', features);
</SCRIPT>
SCRIPT
}

sub popup {
  my $html = shift(@_);
  my $popup_start = "<SCRIPT>windowHandle.document.writeln('";
  my $popup_stop = "')</SCRIPT>";
  return ("$popup_start" . "$html" . "$popup_stop");
}


# The Clever Rules filtering code...
# The outer block makes the private variable $row persistent between calls to sub
{
  my $row;
  sub filter {
    my @filtered = (); # the array to be returned
    my %data = (); # private hash used to organise this instance of clone data
    my %strands = (); # hash to record counts of chr/strand configs
    my %config = (); # hash to associate these configs with clones
    my %seen = (); # hash to record instances
    my %flattened = (); # flatten everything down into this hash
    my ($x,$y,$bin_x,$bin_y) = ($_[1],$_[2],$_[3],$_[4]);
    open (LOG, ">>$logfile") or die "Couldn't open logfile ($!)\n";
    print LOG "\nChr$x" . "Bin$bin_x" . "::" . "Chr$y" . "Bin$bin_y\n";
  CLONE: foreach my $clone (@{$_[0]}) {
      my $strands = '';
    READ: foreach my $read ("F", "R") {
	my $feature = "$clone" . "_" ."$read";
	my $f; #### Code for multiple classes
	foreach my $class(@classes) {
	  last if (($f) = $db->get_feature_by_name($class => $feature));
	}
	if ($f) {
	  my $strand = $f->strand;
	  $strand = ($strand eq '1') ? "+" : "-";
	  my $ref = $f->refseq;
	  my $start = $f->start;
	  my $stop = $f->stop;
	  $strands .= "$ref" . "$strand" . "::"; # Records the chr/strand disposition
	  # Now we define a segment containing this BACend, expanding the
	  # range outwards - within reason - until we find a gene model
	  my $gene = 'undef';
	  my ($seg_start,$seg_stop) = ($start,$stop);
	  my $i = 0;
	  while ($gene eq 'undef' && $i <= $gene_iterations) {
	    $i++;
	    # NB. because we call in scalar context, we have to ensure that a single
	    # segment is returned to avoid an exception being thrown
	    my $segment = $db->segment(-name => $ref,
				       #-absolute => 1,
				       -start => $seg_start,
				       -stop => $seg_stop,
				      );
	    if (my (@genes) = $segment->overlapping_features(-types => 'Gene')) {
	      ($gene) = $genes[0] =~ /^[\w\W]+?\(([\w\W]+?)\)/;
	    }
	    $seg_start -= $gene_window;
	    $seg_stop += $gene_window;
	    #last if ($seg_start < 1 || );
	  }# End while $gene
	  $data{$clone}{$read}{chr} = $ref;
	  $data{$clone}{$read}{strand} = $strand;
	  $data{$clone}{$read}{end} = ($start < $stop) ? $stop : $start; # Furthest extent??
	  $data{$clone}{$read}{gene} = $gene;
	}
      }# End foreach $read

      # Print the unfiltered details to log here
      print LOG "$clone\t" if $log;
      my @details = ();
      my $ordered = '';
      # Flatten the attributes into a single colon-separated string
      foreach my $read ('F', 'R') {
	my $list = '';
	foreach my $attribute (sort keys %{$data{$clone}{$read}}) {
	  $list .= "$data{$clone}{$read}{$attribute}:";
	}
	push @details, $list;
      }

      # "Order" the strings (numerical sort on first chromosome) and put into hash
      $ordered = ($details[0] lt $details[1]) ? "$details[0]"."$details[1]" : "$details[1]"."$details[0]";
      print LOG "$ordered\n" if $log;
      $flattened{$clone} = $ordered;

      # Now we can do an early check for simple duplicates of clones
      if ($seen{$ordered}++) {
	delete $data{$clone};
	delete $flattened{$clone};
	print LOG "(Eliminated clone $clone : probable duplicate)\n" if $log;
	next CLONE;
      }

      # Eliminate clones with an undefined gene neighbour
      if ($ordered =~ /undef/) {
	delete $data{$clone};
	delete $flattened{$clone};
	print LOG "(Eliminated clone $clone : gene neighbour undefined)\n" if $log;
	next CLONE;
      }

      # Decompose $strands composite attributes, and rearrange in Chr order, to allow comparisons
      if ($strands =~ /(\d)([\+\-])::(\d)([\+\-])/) {
	# Special case for intrachromosomal comparisons, rearrange in gene model order
	if ($1 == $3) {
	  $strands = ($data{$clone}{F}{gene} lt $data{$clone}{R}{gene}) ? "$1$2::$3$4" : "$3$4::$1$2";
	}
	else {
	  $strands = ($3 > $1) ? "$1$2::$3$4" : "$3$4::$1$2";
	}
      }
      $strands{$strands}++; # Count incidences of configs
      $config{$clone} = $strands; # Associate clones with configs

    }# End foreach $clone

    # Early return with an empty list if we've already eliminated too many clones
    return @filtered unless (keys %flattened >= $min);

    # Beginning of the filtering process proper...
    # First, establish the majority chr/strand configuration of the ends
    print LOG "Chr/strand configurations\n" if $log;
    my $majority = '';
    my $unique = 0;
    foreach my $config (sort { $strands{$a} <=> $strands{$b} } keys %strands) {
      print LOG "$config\t$strands{$config}\n" if $log;
      $majority = $config;
      if ($strands{$config} == 1) {$unique = 1; }
    }
    # If number of clones > 2, eliminate any clone with a unique chr/strand config
    if (keys(%data) > 2 && $unique) {
      foreach my $clone (keys %data) {
	if ($config{$clone} ne $majority && $strands{$config{$clone}} == 1) {
	  delete $data{$clone};
	  delete $flattened{$clone};
	  print LOG "(Eliminated clone $clone : unique Chr/strand configuration)\n" if $log;
	last;
	}
      }
    }
    # Early return with an empty list if we've eliminated too many clones
    return @filtered unless (keys %flattened >= $min);

    # Eliminate any clones whose gene neighbours we've seen before (aggressive)
    my %gene_neighbours = ();
    foreach my $clone (keys %flattened) {
      my @list = split(/:/,$flattened{$clone});
      if ($gene_neighbours{$list[2]}++ || $gene_neighbours{$list[6]}++ ) {
	print LOG "(Eliminated clone $clone : gene neighbour already seen)\n" if $log;
        delete $data{$clone};
	delete $flattened{$clone};
        next;
      }
    }
    # Early return with an empty list if we've eliminated too many clones
    return @filtered unless (keys %flattened >= $min);

    if ($paralogue_cleanup eq 'weak') {
      # Look up BACends vs AGI genes here to trap possible paralogue conflation?
      # This version simply looks for conflict between the best hit called by the two methods
      foreach my $clone(keys %data) {
	foreach my $read('F','R') {
	  my $end = "$clone" . "_" ."$read";
	  if (exists $genes{$end}) {
	    my ($gene_blast) = $genes{$end}[0] =~ /(\w+)\.\d+\(\d+\)/;
	    #if ($gene_blast ne $data{$clone}{$read}{gene}) {
	    if (distance($gene_blast,$data{$clone}{$read}{gene}) eq 'undef' ||
		distance($gene_blast,$data{$clone}{$read}{gene}) >= $gene_tolerance) {
	      print LOG "(Eliminated clone $clone : for $end, chr BLAST gave $data{$clone}{$read}{gene} but gene BLAST gave $gene_blast)\n" if $log;
	      delete $data{$clone};
	      delete $flattened{$clone};
	      last;
	    }
	  }
	}
      }
      # Early return with an empty list if we've eliminated too many clones
      return @filtered unless (keys %flattened >= $min);
    }

    if ($paralogue_cleanup eq 'strong') {
      # Look up BACends vs AGI genes here to trap possible paralogue conflation?
      # This version attempts to look for any alternative hits that would bring the clone into
      # microsynteny range. If so, the clone is eliminated
      foreach my $clone(keys %data) {
	READ: foreach my $read('F','R') {
	  my $this_end = "$clone" . "_" ."$read";
	  #(my $other_end = $read) =~ tr/FR/RF/;
	  my $other_end = ($read eq 'F') ? 'R' : 'F';
	  my $that_end = $clone . "_" . $other_end;
	  if (exists $genes{$that_end}) {
	    foreach my $hit(@{$genes{$that_end}}) {
	      my ($gene_blast) = $hit =~ /(\w+)\.\d+\(\d+\)/;
	      next unless (defined $gene_blast && defined $data{$clone}{$read}{gene});
	      if (distance($data{$clone}{$read}{gene},$gene_blast) ne 'undef' &&
		  distance($data{$clone}{$read}{gene},$gene_blast) <= $microsynteny) {
		print LOG "(Eliminated clone $clone : $this_end chr BLAST gave $data{$clone}{$read}{gene}, gene BLAST hit for $that_end gave $gene_blast " . "- separation " . distance($data{$clone}{$read}{gene},$gene_blast) . ")\n" if $log;
		delete $data{$clone};
		delete $flattened{$clone};
		last READ;
	      }
	    }
	  }
	}
      }
      # Early return with an empty list if we've eliminated too many clones
      return @filtered unless (keys %flattened >= $min);
    }

    # Eliminate clones whose end-points fall outside a given window
    # First establish the means ...
    my ($sum_1,$sum_2,$mean_1,$mean_2,$i) = 0;
    foreach my $clone (keys %flattened) {
      my @list = split(/:/,$flattened{$clone});
      ++$i;
      $sum_1 += $list[1];
      $sum_2 += $list[5];
    }
    $mean_1 = $sum_1/$i;
    $mean_2 = $sum_2/$i;
    foreach my $clone (keys %flattened) {
      my @list = split(/:/,$flattened{$clone});
      if (abs($list[1]-$mean_1) > $end_window && abs($list[5]-$mean_2) > $end_window) {
	print LOG "(Eliminated clone $clone : endpoints outside " . commas($end_window) .  " range)\n" if $log;
	delete $data{$clone};
      }
    }

    close LOG;

    # Final export of @filtered list to main block and also print to spreadsheet
    if (keys %data >= $min) {
      $row++;
      $worksheet->write($row,0,"Chr$x" . "Bin$bin_x" . "::" . "Chr$y" . "Bin$bin_y",$column_format{0});
      $row++;
      foreach my $clone (sort keys %data) {
	push @filtered, $clone;
	my $col = 0;
	# Sort the reads according to gene model number, aids visual inspection
	my @print_order = ($data{$clone}{F}{gene} lt $data{$clone}{R}{gene}) ? ('F','R') : ('R','F');
	$worksheet->write($row,$col,"$clone",$column_format{$col});
	#foreach my $read ('F','R') {
	foreach my $read(@print_order) {
	  foreach my $attribute (sort keys %{$data{$clone}{$read}}) {
	    $worksheet->write($row,++$col,"$data{$clone}{$read}{$attribute}",$column_format{$col});
	  }
	  ++$col;
	}
	++$row;
      }
    }
    return @filtered;
  }
}

# All the stuff to instantiate a spreadsheet object and to export cell formats
sub init_spreadsheet {
  $worksheet = $workbook->addworksheet();
  $worksheet->freeze_panes(1, 0);
  $worksheet->set_footer('Page &P of &N');
  $worksheet->set_landscape();
  $worksheet->set_margins_LR(0.4);
  $worksheet->set_margins_TB(0.8);

  # Define cell formats, the $head_formats' scope can be localised to this sub
  my $head_format = $workbook->addformat( bold => 1,
					  align => 'left',
					  fg_color => 'yellow',
					  font => 'Arial',
					  size => 10,
					  pattern => 1);
  my $head_format2 = $workbook->addformat( bold => 1,
					  align => 'center',
					  fg_color => 'silver',
					  font => 'Arial',
					  size => 10,
					  pattern => 1);
  $default_format = $workbook->addformat( align => 'left',
					  font => 'Arial',
					  size => 10,
					  color => 'black');
  $num_format = $workbook->addformat( align => 'right',
				     font => 'Courier',
				     size => 10,
				     num_format => '##,###,###', # Let the module do this
				     color => 'black');

  # Assign global format objects into hash, keyed by spreadsheet column number
  %column_format = (
		    0 => $default_format,
		    1 => $default_format,
		    2 => $num_format,
		    3 => $default_format,
		    4 => $default_format,
		    5 => $default_format,
		    6 => $default_format,
		    7 => $num_format,
		    8 => $default_format,
		    9 => $default_format,
		   );

  # Write the spreadsheet header row
  $worksheet->write(0, 0, "Clone", $head_format);
  $worksheet->set_column(0, 0, 11);
  $worksheet->write(0, 1, "Chr", $head_format);
  $worksheet->set_column(1, 1, 3);
  $worksheet->write(0, 2, "Coordinate", $head_format);
  $worksheet->set_column(2, 2, 12);
  $worksheet->write(0, 3, "Gene neighbour", $head_format);
  $worksheet->set_column(3, 3, 15);
  $worksheet->write(0, 4, "Strand", $head_format);
  $worksheet->set_column(4, 4, 6);
  $worksheet->write(0, 5, "", $head_format);
  $worksheet->set_column(5, 5, 5);
  $worksheet->write(0, 6, "Chr", $head_format);
  $worksheet->set_column(6, 6, 3);
  $worksheet->write(0, 7, "Coordinate", $head_format);
  $worksheet->set_column(7, 7, 12);
  $worksheet->write(0, 8, "Gene neighbour", $head_format);
  $worksheet->set_column(8, 8, 15);
  $worksheet->write(0, 9, "Strand", $head_format);
  $worksheet->set_column(9, 9, 6);
  $worksheet->write(0, 10, "Binsize=$binsize SeqID>=$identity% Clones>=$min", $head_format2);
  $worksheet->set_column(10,10,40);
}

# Nice up the big numbers
# NB Spreadsheet::WriteExcel does this through its own formatting but we use this elsewhere
sub commas {
  my $i = shift;
  return $i if $i=~ /\D/;
  $i = reverse $i;
  $i =~ s/(\d{3})/$1,/g;
  chop $i if $i=~/,$/;
  $i = reverse $i;
  $i;
}

# A little sub to calculate the physical distance between gene models
sub distance {
  #open (TRACE, ">>/tmp/sniffer_trace.$$");
  my @genes = @_;
  my @coords = ();
  my @chrs = ();
  foreach my $gene(@genes) {
    if (my ($f) = $db->get_feature_by_name('Gene' => $gene)) {
      push @chrs, $f->ref;
      push @coords, $f->start;
    }
  }
 # for (my $i=0; $i<=$#genes; $i++) {
 #   print TRACE "$genes[$i] $chrs[$i] $coords[$i]\n";
 # }
 # close TRACE;
  unless (defined $chrs[0] && defined $chrs[1]) { return 'undef'; }
  if ($chrs[0] ne $chrs[1]) {
    return 'undef';
  }
  else {
    return abs($coords[0] - $coords[1]);
  }
}
