#!/home/martink/bin/perl 

=pod

=head1 NAME

orderchr - determine a chromosome order to minimize cross-over of links

=head1 SYNOPSIS

  orderchr -links linkfile.txt { -shufflefile chrs_to_shuffle.txt | -shufflerx REGEX } {-staticrx REGEX} {-karyotype karyotype.txt}

=head1 READ FIRST

This ordering script is most suitable for dense link data
(many-to-many) (i.e. significant fraction of all chromosome pairs have
links). If your data is sparse (one-to-many) (i.e. many chromosomes
receive links from only one chromosome), please try tools/orderchr-deterministic.

=head1 DESCRIPTION

By examining the frequencies of chromosome-chromosome relationships
defined in the link file, this script suggests a new order for
chromosomes that results in fewer cross-overs between links. Simulated
annealing is used to optimize the chromosome order (read below about
parameters). Run the simulation a couple of times to check convergence
(finding a global minimum is not guaranteed).

=head1 DEFINING WHICH CHROMOSOMES TO SHUFFLE

The set of chromosomes to shuffle is specified by either (a) link
data, whereby all chromosomes that have links are subject to shuffling
(b) -shufflefile, whereby only those chromosomes listed in the file
are shuffled (c) -shufflerx, whereby only those chromosomes that match
a regular expression are shuffled. Any chromosome that is not
identified by one of these methods does not participate in the
shuffling process. Specifically, any links to/from such chromosomes
are not considered when minimizing link crossing.

There are several modes in which the script is run and each mode
differs in the way shuffle eligibility of chromosomes is defined.

=head2 MODE 1 - shuffle set defined by link data

  > orderchr -links linkfile.txt 

All chromosomes mentioned in the -links file will be subject to reordering.

=head2 MODE 2 - shuffle set defined by regular expression 

  > orderchr -links linkfile.txt -shufflerx chr1

The set of chromosomes with links is filtered by a regular expression
and only those chromosomes that match the regular expression are
shuffled.

In this example, chromosomes matching "chr1" will be shuffled (e.g. chr1, chr10, chr11, etc).

=head2 MODE 3 - shuffle set defined by file

  > orderchr -links linkfile.txt -shufflefile chrs_to_shuffle.txt

The set of chromosomes to shuffle is given in the -shufflefile file,
which contains one chromosome per line. For example

  > cat chrs_to_shuffle.txt
  chr1
  chr5
  chr12
  chr17
  ...

=head1 DEFINING WHICH CHROMOSOMES TO REMAIN ANCHORED

After the shuffle chromosome set has been defined, you can further
limit shuffling by forcing a subset of those chromosomes to remain in
the same order throughout the shuffling process. This is done by a regular expression

  > orderchr -links linkfile.txt -staticrx chr1

In this example, all chromosomes matching the regular expression chr1
will not have their order adjusted. Any links to/from these
chromosomes will contribute to the total link crossing score, but the
chromosomes themselves will not be moved. For example, if the original order of chromosomes is

  chr1,chr2,chr3,chr10,chr11,chr20,chr21

then any shuffle solution will have the order

  chr1,-,-,chr10,chr11,-,-

with chr1, chr10 and chr11 remaining fixed.

=head1 SIMULATED ANNEALING

This method is an optimization method that encourages the discovery of
a global minimum by traversing the space of solutions with a small
(and decreasing as simulation runs) chance of visiting less desirable
solutions. 

There are three parameters that control the optimization.

=head2 iterations

The number of iterations to perform. At each iteration, the current
solution is randomly modified and either accepted or rejected.

=head2 max_flips

The optimization run is split into max_flips equal-sized
intervals. During each iterval (i=1..max_flips), the number of random
chromosome pair swaps in the solution is given by

  max_flips - i + 1

For example, if max_flips is 3 and iterations=1000. Then the number of random pair swaps is

  iteration 1-333    3
  iteration 334-666  2
  iteration 667-1000 1

I suggest starting with a value that corresponds to 5% of the chromosomes. For example, if you have 100 chromosomes, use max_flips=5 to start.

=head2 temp0

This parameter determines the probability of a transition to a less desirable solution. The transition probability is

  p(dE) = temp0*exp( - dE/t )

where t=1..0 over the length of the simulation and dE is the relative change in the desirability of two solutions. 

If temp0=1, then the probability of accepting a solution that is 10% worse (e.g. dE=0.1) is

  p(0.1) = exp (-0.1/1)   = 90%    at start of simulation
         = exp (-0.1/0.5) = 82%    half way through simulation
         = exp (-0.1/0.1) = 37%    90% of the way through simulation

By lowering temp0, you lower the probability of transition to a less desirable solution. 

Do not adjust temp0 unless you feel that the simulation is (a) not
traversing the solution space sufficiently - in which case make temp0
larger or (b) too many low-quality solutions are accepted - in which
case make temp0 smaller.

=head2 optimize = minimize|maximize

Most of the time you'll want to adjust the chromosome order in a way
to minimize the number of crossing links. However, you can set to maximize the number of crossing links by setting

  optimize = maximize

=head1 HISTORY

=over

=item * 8 July 2008

Started and versioned.

=back 

=head1 BUGS

=head1 AUTHOR

Martin Krzywinski

=head1 CONTACT

  Martin Krzywinski
  Genome Sciences Centre
  Vancouver BC Canada
  www.bcgsc.ca
  martink@bcgsc.ca

=cut

################################################################
#
# Copyright 2002-2008 Martin Krzywinski
#
# This file is part of the Genome Sciences Centre Perl code base.
#
# This script 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 2 of the License, or
# (at your option) any later version.
#
# This script 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 script; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
################################################################

################################################################
#                           Martin Krzywinski (martink@bcgsc.ca)
#                                                           2008
################################################################

use strict;
use Config::General;
use Data::Dumper;
use File::Basename;
use FindBin;
use Getopt::Long;
use IO::File;
use Math::VecStat qw(sum min max average);
use Memoize;
#use Devel::DProf;
use Pod::Usage;
use Time::HiRes qw(gettimeofday tv_interval);
use lib "$FindBin::RealBin";
use lib "$FindBin::RealBin/../lib";
use lib "$FindBin::RealBin/lib";
use vars qw(%OPT %CONF);

################################################################
#
# *** YOUR MODULE IMPORTS HERE
#
################################################################

#memoize("get_num_links");

GetOptions(\%OPT,
	   "links=s",
	   "anchorfile=s",
	   "anchorrx=s",
	   "optimize=s",
	   "karyotype=s",
	   "configfile=s","help","man","debug+");

pod2usage() if $OPT{help};
pod2usage(-verbose=>2) if $OPT{man};
loadconfiguration($OPT{configfile});
populateconfiguration(); # copy command line options to config hash
validateconfiguration(); 
if($CONF{debug} > 1) {
  $Data::Dumper::Pad = "debug parameters";
  $Data::Dumper::Indent = 1;
  $Data::Dumper::Quotekeys = 0;
  $Data::Dumper::Terse = 1;
  print Dumper(\%CONF);
}

my $link_count = parse_links($CONF{links});
my $k          = read_karyotype($CONF{karyotype});
my $anchors;
if($CONF{anchorfile}) {
  $anchors    = parse_anchors($CONF{anchorfile});
} else {
  my $rx = $CONF{anchorrx} || ".";
  if($k) {
    $anchors = [ grep($_ =~ /$rx/, map {$_->{chr}} @{$k->{chr}})];
  } else {
    $anchors = [ grep($_ =~ /$rx/, sort keys %{$link_count} ) ];
  }
}

my @order      = @$anchors;
my $score      = calculate_overlap(@order);
my $score_orig = $score;
my ($score_best,@order_best);
printinfo("score",$score,@order);
for my $curr_iter (1..$CONF{iterations}) {
  # adjust order
  my @neworder = @order;
  my $nflips = 1+int(($CONF{iterations}-$curr_iter)/($CONF{iterations}/$CONF{max_flips}));
  @neworder = flip_chromosomes($nflips,@neworder);
  my $time = [gettimeofday];
  my $newscore = calculate_overlap(@neworder);
  $time = tv_interval($time);
  my $dscore   = $score_orig ? ($newscore - $score) / $score_orig : 1;
  my $temp     = $CONF{temp0}*($CONF{iterations}-$curr_iter+1)/$CONF{iterations};
  my $accept;
  if( ($CONF{optimize} eq "minimize" && $dscore < 0) ||
      ($CONF{optimize} eq "maximize" && $dscore > 0) ) {
    $accept = 1;
  } else {
    my $p = exp( - abs($dscore)/$temp );
    $accept = 1 if rand() < $p;
  }
  if($accept) {
    @order = @neworder;
    $score = $newscore;
    if(! defined $score_best ||
       ( ($CONF{optimize} eq "minimize" && $score < $score_best) ||
	 ($CONF{optimize} eq "maximize" && $score > $score_best) )) {
      $score_best = $score;
      @order_best = @order;
    }
  }
  $CONF{debug} && printinfo(sprintf("%s %s %d/%d curr %d best %d change %.2f%% time %.3f",
				    $CONF{optimize},
				    $accept?"accept":"reject",
				    $curr_iter,$CONF{iterations},
				    $newscore,$score_best,
				    defined $score_orig && defined $score_best ? 100*abs($score_orig-$score_best)/$score_orig : 0,
				    $time));
}

$CONF{debug} && printinfo(sprintf("improvement($CONF{optimize}) orig %d final %d change %.2f%%",
				  $score_orig,
				  $score_best,
				  defined $score_orig && defined $score_best ? 100*abs($score_orig-$score_best)/$score_orig : 0));
printinfo("chromosomes_order =",join(",",@order_best));

sub flip_chromosomes {
  my $nflips = shift;
  my @order  = @_;
  my @neworder = @order;
  my @flippable;
  if($CONF{staticrx}) {
    @flippable = grep($neworder[$_] !~ /$CONF{staticrx}/, (0..@order-1));
  } else {
    @flippable = (0..@order-1);
  }
  for my $flip (1..$nflips) {
    my ($i,$j);
    do {
      ($i,$j) = ($flippable[rand(@flippable)],$flippable[rand(@flippable)]);
    } while ($i==$j);
    @neworder[$i,$j] = @neworder[$j,$i];
  }
  return @neworder;
}

sub calculate_overlap {
  my @order = @_;
  my $n = @order;
  my $score;

  for my $i (0..$n-2) {
    for my $j ($i+2..$n-1) {
      my ($ci,$cj) = @order[$i,$j];
      $CONF{debug} >1 && printdebug("nodepair",$i,$j,$ci,$cj);
      my $nlinks = $link_count->{$ci}{chr}{$cj};
      next unless $nlinks;
      # indexes of chromosome groups bisected by the line
      # between chromosomes $i and $j
      my @g1 = ($i+1..$j-1);
      my @g2 = ($j+1..$n-1,0..$i-1);

      $CONF{debug} >1 && printdebug("g1",@g1);
      $CONF{debug} >1 && printdebug("g2",@g2);
      
      my %g1 = map { $order[$_],$_ } @g1;
      my %g2 = map { $order[$_],$_ } @g2;
      
      # contribution to cross-over across $i-$j line
      my $xlinks;
      for my $c1 (keys %$link_count) {
	next unless exists $g1{$c1};
	for my $c2 (keys %{$link_count->{$c1}{chr}}) {
	  next unless exists $g2{$c2};
	  my $nl = $link_count->{$c1}{chr}{$c2};
	  next unless $nl;
	  $xlinks += $nl;
	}
      }
      $score += $nlinks * $xlinks;

      # contribution to cross-over between $ci and next group
      for my $data ( [$ci,1,\@g1],
		     [$ci,-1,\@g2],
		     [$cj,1,\@g2],
		     [$cj,-1,\@g1] ) {
	my ($dci,$ddir,$group) = @$data;
	my @l;
	my %grpidx;
	for my $k (grep($link_count->{$dci}{pos}{ $order[$_] }, @$group)) {
	  my $ck = $order[$k];
	  $grpidx{$ck} = int(keys %grpidx);
	  push @l, @{$link_count->{$dci}{pos}{$ck}};
	}
	my $ixlinks;
	if(@l) {
	  if($ddir == 1) {
	    @l = sort { $b->{p1} <=> $a->{p1} } @l;
	  } else {
	    @l = sort { $a->{p1} <=> $b->{p1} } @l;
	  }
	  for my $ii (0 .. @l-1) {
	    my $li = $l[$ii];
	    for my $jj ($ii+1 .. @l-1) {
	      my $lj = $l[$jj];
	      my $cli = $li->{c2};
	      my $clj = $lj->{c2};
	      if($ddir == 1) {
		next if $grpidx{ $clj } > $grpidx { $cli };
		next if $grpidx{ $clj } == $grpidx { $cli } && $lj->{p2} < $li->{p1};
	      } else {
		next if $grpidx{ $clj } < $grpidx { $cli };
		next if $grpidx{ $clj } == $grpidx { $cli } && $lj->{p2} > $li->{p1};
	      }
	      $ixlinks++;
	      $CONF{debug} > 1 && printinfo("cross",
					    $ii,
					    @{$li}{qw(c1 p1 c2 p2)},
					    $jj,
					    @{$lj}{qw(c1 p1 c2 p2)},
					   );
	    }
	  }
	}
	$score += $ixlinks;
      }
    }
  }

  return $score;
}

sub read_karyotype {
  my $file = shift;
  return undef if ! -e $file;
  open(F,$file);
  my $k;
  while(<F>) {
    chomp;
    if(/^chr/) {
      my @tok = split;
      my $chr = $tok[2];
      push @{$k->{chr}}, {chr=>$chr, tok=>\@tok};
    } else {
      push @{$k->{band}}, $_;
    }
  }
  return $k;
}

sub get_num_links {
  my ($chr1,$chr2) = @_;
  if(defined $chr2) {
    return $link_count->{$chr1}{chr}{$chr2};
  } else {
    return $link_count->{$chr1}{total};
  }
}

################################################################
#
# count the number of links between any two chromosomes
#
# between CHR1 and CHR2
# $link_count->{CHR1}{chr}{CHR2}
# out of CHR1 (first coordinate in link)
# $link_count->{CHR1}{out}
# into CHR1 (second coordinate in link)
# $link_count->{CHR1}{in}
# total CHR1 links
# $link_count->{CHR1}{total}

sub parse_links {
  my $file = shift;
  open(F,$file);
  my $link_count;
  while(<F>) {
    chomp;
    my @tok1 = split;
    my $line2 = <F>;
    last unless $line2;
    chomp $line2;
    my @tok2 = split(" ",$line2);
    my $pos1 = ($tok1[2]+$tok1[3])/2;
    my $pos2 = ($tok2[2]+$tok2[3])/2;
    my ($chr1,$chr2) = ($tok1[1],$tok2[1]);
    $CONF{debug} > 1 && printdebug("link",$chr1,$chr2);
    push @{$link_count->{$chr1}{pos}{$chr2}}, { c1=>$chr1, c2=>$chr2, p1=>$pos1, p2=>$pos2 };
    push @{$link_count->{$chr2}{pos}{$chr1}}, { c1=>$chr2, c2=>$chr1, p1=>$pos2, p2=>$pos1 };
    $link_count->{$chr1}{chr}{$chr2}++;
    $link_count->{$chr2}{chr}{$chr1}++;
    if($chr1 ne $chr2) {
      $link_count->{$chr1}{out}++;
      $link_count->{$chr2}{in}++;
      $link_count->{$chr1}{total}++;
      $link_count->{$chr2}{total}++;
    }
  }
  return $link_count;
}

sub parse_anchors {
  my $file = shift;
  open(F,$file);
  my $anchors;
  while(<F>) {
    chomp;
    push @$anchors, $_;
  }
  return $anchors;
}

sub validateconfiguration {
  $CONF{optimize} ||= "minimize";
}

################################################################
#
# *** DO NOT EDIT BELOW THIS LINE ***
#
################################################################

sub populateconfiguration {
  foreach my $key (keys %OPT) {
    $CONF{$key} = $OPT{$key};
  }

  # any configuration fields of the form __XXX__ are parsed and replaced with eval(XXX). The configuration
  # can therefore depend on itself.
  #
  # flag = 10
  # note = __2*$CONF{flag}__ # would become 2*10 = 20

  for my $key (keys %CONF) {
    my $value = $CONF{$key};
    while($value =~ /__([^_].+?)__/g) {
      my $source = "__" . $1 . "__";
      my $target = eval $1;
      $value =~ s/\Q$source\E/$target/g;
      #printinfo($source,$target,$value);
    }
    $CONF{$key} = $value;
  }

}

sub loadconfiguration {
  my $file = shift;
  my ($scriptname) = fileparse($0);
  if(-e $file && -r _) {
    # great the file exists
  } elsif (-e "/home/$ENV{LOGNAME}/.$scriptname.conf" && -r _) {
    $file = "/home/$ENV{LOGNAME}/.$scriptname.conf";
  } elsif (-e "$FindBin::RealBin/$scriptname.conf" && -r _) {
    $file = "$FindBin::RealBin/$scriptname.conf";
  } elsif (-e "$FindBin::RealBin/etc/$scriptname.conf" && -r _) {
    $file = "$FindBin::RealBin/etc/$scriptname.conf";
  } elsif (-e "$FindBin::RealBin/../etc/$scriptname.conf" && -r _) {
    $file = "$FindBin::RealBin/../etc/$scriptname.conf";
  } else {
    return undef;
  }
  $OPT{configfile} = $file;
  my $conf = new Config::General(-ConfigFile=>$file,
				 -AllowMultiOptions=>"yes",
				 -LowerCaseNames=>1,
				 -AutoTrue=>1);
  %CONF = $conf->getall;
}

sub printdebug {
  printinfo("debug",@_)  if $CONF{debug};
}

sub printinfo {
  printf("%s\n",join(" ",@_));
}

