#!/usr/bin/env perl

=pod

=head1 NAME

parse-table - parse tabular data, such as created by make-table, and
report values suitable for make-conf which creates Circos input files
to visualize the table

=head1 SYNOPSIS

  cat table.txt | parse-table

  parse-table -file table.txt

=head1 DESCRIPTION

This script parses tabular data and generates the circos input and
configuration files used to create circular table views as described
here

 http://mkweb.bcgsc.ca/tableviewer/

=head1 INPUT FORMAT

All input files must be plain-text. The simplest format is

  - D E F
  A 1 2 3
  B 4 5 6
  C 7 8 9

The first row contains the column labels and the first column contains
row labels. Value of the first cell is unimportant (e.g. '-') but
required to keep the number of fields in each row constant.

Three additional rows and columns can be added, which specify the order
of rows/columns, their color and their size.

Order values are used to determine placement of column and row segments.

  # table with order values
  # 
  # requires
  #  col_order_row = yes
  #  row_order_col = yes
  - - 3 6 5
  - - D E F
  1 A 1 2 3
  4 B 4 5 6
  2 C 7 8 9

  # table with color values 
  #
  # requires
  #  col_color_row = yes 
  #  row_color_col = yes
  -         - 255,0,0 0,255,0 0,0,255
  -         - D E F
  255,255,0 A 1 2 3
  255,0,255 B 4 5 6
  0,255,255 C 7 8 9

  # table with row order and color values
  #
  # requires
  #  col_order_row = yes
  #  row_order_col = yes
  #  col_color_row = yes 
  #  row_color_col = yes
  -         - - 3 6 5
  -         - - 255,0,0 0,255,0 0,0,255
  -         - - D E F
  1 255,255,0 A 1 2 3
  4 255,0,255 B 4 5 6
  2 0,255,255 C 7 8 9

To specify the color of a subset of columns and rows, use "-" in color cells for which there is no color value.

=head1 SAMPLE DATA

There are various sample data files in C<samples/>. You can create images for each of the sample data sets using the C<makeimage> script

  makeimage 01
  makeimage 02a
  makeimage 02b
  makeimage 02c
  makeimage 02d
  makeimage 03
  makeimage 04a
  makeimage 04b
  makeimage 05
  makeimage 06

=head1 CONFIGURATION

All configuration parameters are controlled by the configuration
file. For details about the file's structure, see
C<etc/parse-table.conf>.

=head1 HISTORY

=over

=item * 26 Nov 2012 v0.31

No longer uses Graphics::ColorObject.

=item * 22 Nov 2012 v0.3

Updated documentation.

=item * 1 Apr 2009 v0.2

Added new segment order schemes: row_size, col_size, row_to_col_ratio, col_to_row_ratio, file.

Added ability to represent (A,B)=x and (B,A)=y table values as one ribbon of thickness x at segment A and y at segmetn B.

Added ability to normalize segment sizes using these schemes: total, average, row_total, col_total, row_average, col_average, or uniform.

Added ability to have segments internally named after row/col labels. Previously each segment had an internally generated name (e.g. id0, id1, etc).

Added ability to layer ribbons (ribbon_layer_order) using these schemes: size_desc, size_asc

Added strip_leading_space and remove_lines_rx parameters to toggle removal of any leading spaces in input lines and remove lines that match a given regular expression.

Added field_delim parameter to explicitly specify field delimiter in the input file. By default, this is set to space. Note that adjacent delimiters will not be collapsed and will be interpreted to define an empty cell.

Added percentile_data_domain to generate percentile color palette based on either raw or filtered values.

Added cell_remap_formula to allow remapping of cell values.

Added colour_source in <linkcolor> block to specify whether ribbons are colored by row or column segments.

=item * 21 Jan 2009 v0.1

Standardized configuration and added segment/cell order features.

Bundled with Circos distribution. 

=item * 25 Jun 2008 

Added more error traps.

=item * 11 June 2008

Continuing to refine and debug.

=item * 2 June 2008

Versioned and updated.

=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-2012 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
#
################################################################

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 Math::Round qw(round nearest);
use Pod::Usage;
use Set::IntSpan;
use Statistics::Descriptive;
use Storable;
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);

use tableviewer_io;
use tableviewer_format;

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

GetOptions(\%OPT,

	   "file=s",
	   "color_prefix=s",
	   "skip_rows=i",

	   "header",

	   "row_order_col",
	   "col_order_row",
	   "use_row_order_col",
	   "use_col_order_row",

	   "row_color_col",
	   "col_color_row",
	   "use_row_color_col",
	   "use_col_color_row",

	   "row_size_col",
	   "col_size_row",
	   "use_row_size_col",
	   "use_col_size_row",

	   "intra_cell_exclude",
	   "intra_cell_size_remove",

	   "size_recompute",

	   "use_scaling",
	   "scale_factor=f",

	   "segment_order=s",
	   "segment_color_order=s",

	   "percentile_sampling=f",

	   "percentile_hue_start=i",
	   "percentile_hue_end=i",

	   "percentile_saturation_start=i",
	   "percentile_saturation_end=i",

	   "percentile_brightness_start=i",
	   "percentile_brightness_end=i",

	   "cell_q1_transparency=i",
	   "cell_q2_transparency=i",
	   "cell_q3_transparency=i",
	   "cell_q4_transparency=i",
	   "cell_q1_color=s",
	   "cell_q2_color=s",
	   "cell_q3_color=s",
	   "cell_q4_color=s",
	   "cell_q1_nostroke",
	   "cell_q2_nostroke",
	   "cell_q3_nostroke",
	   "cell_q4_nostroke",

	   "cell_min_percentile=f",
	   "cell_max_percentile=f",
	   "cell_min_value=f",
	   "cell_max_value=f",

	   "data_mult=f",

	   "color_idx_mult=f",
	   "color_remap",
	   "color_autoremap",

	   "use_segment_normalization",
	   "segment_normalization_scheme=s",

	   "normalize_contribution",

	   "ribbon_bundle_order=s",
	   "ribbon_layer_order=s",

	   "ribbon_variable",

	   "intra_cell_handling=s",

	   "show_parsed",

	   "field_delim=s",
	   "field_delim_collapse!",
	   "strip_leading_space!",
	   "blank_means_missing!",
	   "missing_cell_value=s",
	   "remove_cell_rx=s",
	   
	   "placement_order=s",

	   "reverse_rows",
	   "reverse_columns",

	   "transparency=i",
	   "fade_transparency=i",

	   "color_source=s",

	   "interpolate_type=s",

	   "max_col_num=i",
	   "max_row_num=i",

	   "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);
}

################################################################
# setup the input handle to be the file, if specified, otherwise
# read from STDIN
my $inputhandle = prep_handle($CONF{file});
################################################################

# all the table data (row/column/cell) is stored in $table
# all statistics (row/column/cell/label) is stored in $stat
my $table;

# counters for things such as skipped lines, row index, column index
my $counter;

my ($ncols,$seen,$row_idx,$segment_order,$label_size,$row_idx,$label_color,$nskip);

LINE:
while(<$inputhandle>) {
  chomp;
  # skip lines that match a regular expression
  next if $CONF{remove_lines_rx} && /$CONF{remove_lines_rx}/;
  # skip comment lines
  next if /^\s*\#/;
  my $line = $_;
  next if $CONF{skip_rows} && $counter->{skipped_lines}++ < $CONF{skip_rows};
  my @tok = clean_and_split_line($_);
  next unless @tok;

  # determine the number of columns - do this every time to catch any lines
  # with different number of fields
  printdebug("read line",@tok);
  printdebug("columns in line",@tok+1);
  my $ncols_this_line = @tok;
  if(! defined $ncols) {
    $ncols = $ncols_this_line;
  } elsif ($ncols_this_line != $ncols) {
    report_error("This line [$line] has a different number of columns ($ncols_this_line) than the previous line which had ($ncols) columns. Please make sure that every line has the same number of fields. Empty cells should appear in the input file as either (A) string defined by missing_cell_value (e.g. -), or (B) adjacent delimiters (e.g. 2<tab><tab>3) with -blank_means_missing=yes and field_delim_collapse=no. For an example of how missing data is encoded, see samples/parse-example-N.txt N=2,3");
  }

  # parse column information
  # - extract column names
  # - extract column order, if available
  # - extract column size, if available
  # - extract column color, if available
  # column information is stored in in $table->{col}
  # - $table->{col}{list}[IDX] = $coldata;
  #                              {name,idx,size?,order?,color?}

  if($CONF{col_order_row} && ! $seen->{col_order_row}++) {
    my $skip_cols = $CONF{use_row_order_col} + $CONF{use_row_color_col} + $CONF{use_row_size_col} + 1;
    printdebug("reading column order starting at col",$skip_cols);
    for my $i ( $skip_cols .. $ncols - 1) {
      my $col_idx  = $i - $skip_cols;
      last if $col_idx >= $CONF{max_col_num};
      my $col_order = $tok[$i];
      printdebug("read column order",$col_order,"from column",$i,"col_idx",$col_idx);
      if($CONF{use_col_order_row}) {
	report_error("Column at order value ($tok[$i]) already exists. Please make sure that there are no duplicate order values in the row that specifies column order.") if $seen->{col_order}{$col_order}++;
	$table->{col}{list}[$col_idx]{order} = $col_order;
	report_error("Column order value ($col_order) is not numeric",$line) unless $col_order =~ /^\d+$/;
	printdebug("found column order",$col_idx,$col_order);
      }
    }
    next LINE;
  }

  if($CONF{col_size_row} && ! $seen->{col_size_row}++) {
    my $skip_cols = $CONF{use_row_order_col} + $CONF{use_row_color_col} + $CONF{use_row_size_col} + 1;
    printdebug("reading column size starting at col",$skip_cols);
    for my $i ( $skip_cols .. $ncols - 1) {
      my $col_idx  = $i - $skip_cols;
      last if $col_idx >= $CONF{max_col_num};
      my $col_size = $tok[$i];
      printdebug("read column size",$col_size,"from column",$i,"col_idx",$col_idx);
      if($CONF{use_col_size_row}) {
	report_error("Column size ($col_size) is not numeric. You have specified that a row with column sizes exists, but it doesn't seem that way. Are you sure that your setting of col_size_row=yes is correct?") unless $col_size =~ /^\d*\.?\d*$/;
	$table->{col}{list}[$col_idx]{size} = $col_size;
	printdebug("found column size",$col_idx,$col_size);
      }
    }
    next LINE;
  }

  if($CONF{col_color_row} && ! $seen->{col_color_row}++) {
    my $skip_cols = $CONF{use_row_order_col} + $CONF{use_row_color_col} + $CONF{use_row_size_col} + 1;
    printdebug("reading column color starting at col",$skip_cols);
    for my $i ( $skip_cols .. $ncols - 1) {
      my $col_idx  = $i - $skip_cols;
      last if $col_idx >= $CONF{max_col_num};
      my $col_color = $tok[$i];
      report_error("Column color must be in r,g,b format (e.g. 100,50,150). The value ($col_color) does not match this format."."\n \n"."line: $line") if $col_color && $col_color !~ /^\d+,\d+,\d+$/;
      if($CONF{use_col_color_row}) {
	$table->{col}{list}[$col_idx]{color} = $col_color;
	printdebug("Found column color",$col_idx,$col_color);
      }
    }
    next LINE;
  }
  if($CONF{header} && ! $seen->{header}++) {
    my $skip_cols = $CONF{use_row_order_col} + $CONF{use_row_color_col} + $CONF{use_row_size_col} + 1;
    printdebug("reading column names starting at col",$skip_cols);
    for my $i ( $skip_cols .. $ncols - 1) {
      my $col_idx = $i - $skip_cols;
      last if $col_idx >= $CONF{max_col_num};
      my $name    = parse_label($tok[$i]);
      printdebug("labelparse",$col_idx,$tok[$i],$name);
      if($name eq "") {
	report_error("Blank column name found. This is likely due to multiple adjacent whitespaces in your input and field_delim_collapse=no. If your input uses whitespace and there is more than one whitespace between adjacent fields, make sure field_delim_collapse=yes. Please see sample/parse-example-4.txt");
      }
      if($seen->{col_name}{$name}++) {
	report_error("Duplicate column name ($name) found. Please makes sure that all column names in the header are different.") 
      }
      @{$table->{col}{list}[$col_idx]}{qw(name idx j)} = ($name,$col_idx,$i);
      $segment_order->{$name} = $table->{col}{list}[$col_idx]{order};
      $label_size->{$name}  = $table->{col}{list}[$col_idx]{size};
      printdebug("found column name",$col_idx,$name);

    }
    report_error("could not parse column header") unless $table->{col}{list};
    next LINE;
  }

  ################################################################
  # parse each data row of table

  my $row_idx  = $table->{row}{list} ? @{$table->{row}{list}} : 0;
  last LINE if $row_idx >= $CONF{max_row_num};

  my $col_idx = 0;
  my $row_data;
  # process the row order, if this column exists
  if($CONF{row_order_col}) {
    my $order = $tok[ $col_idx++ ];
    if($CONF{use_row_order_col}) {
      report_error("Row at order value ($order) already exists.") if $seen->{row_order}{$order}++;
      report_error("Row order value ($order) is not numeric.") unless $order =~ /^\d+$/;
      printdebug("found row order",$row_idx,$order);
      $row_data->{order} = $order;
    }
  }
  # process row size, if this column exists
  if($CONF{row_size_col}) {
    my $size = $tok[ $col_idx++ ];
    if($CONF{use_row_size_col}) {
      report_error("Row size value [$row_data->{size}] is not numeric.") unless $size && $size =~ /^\d*\.?\d*$/;
      printdebug("found row size",$row_idx,$size);
      $row_data->{size} = $size;
    }
  }
  # process row color, if this column exists
  if($CONF{row_color_col}) {
    my $color = $tok[ $col_idx++ ];
    printdebug("found color",$color);
    if($CONF{use_row_color_col}) {
      report_error("Row color value ($color) does is not in r,g,b format.") if $color && $color !~ /^\d+,\d+,\d+$/;
      printdebug("found row color",$row_idx,$color);
      $row_data->{color} = $color;
    }
  }
  my $row_name = parse_label($tok[ $col_idx++ ]);
  report_error("Duplicate row name ($row_name) found. Please make sure that all row names are different.") if $seen->{row_name}{$row_name}++;
  printdebug("found row name",$row_idx,$row_name);

  @{$row_data}{qw(name idx)} = ($row_name,$row_idx);
  push @{$table->{row}{list}}, $row_data;
  $row_idx++;

  $segment_order->{$row_name} ||= $row_data->{order};
  $label_size->{$row_name}  += $row_data->{size};

  # now that we've parsed the row fields for order, size, color and name, read in the
  # actual cell values

  # this is done by iterating across the previously collected column data and advancing one field at
  # a time for each column datum

  for my $col_data ( @{$table->{col}{list}} ) {
    # this is the original column position for this column
    my $j = $col_data->{j}; 
    # this is the cell value at this column position 
    my $cell_value = $tok[$j];
    my $cell_value_clean = clean_value($cell_value,$row_data->{name},$col_data->{name});
    printdebug("cleaned value",$cell_value,$cell_value_clean);
    # if the cell value is blank or 0, it will be populated with the missing_cell_value
    # otherwise, apply the data_mult multiplier, if it is defined
    if($cell_value_clean ne "") {
      if($cell_value_clean eq $CONF{missing_cell_value}) {
	# data is missing - keep cleaned value as is
      } elsif ($cell_value_clean =~ /^[+-]?\d*\.?\d*$/) {
	$cell_value_clean *= $CONF{data_mult} if $CONF{data_mult};
	report_error("All cell values must be non-negative, but you have ($row_data->{name},$col_data->{name})=$cell_value_clean") if $cell_value_clean < 0;
      } else {
	report_error("Cell value ($cell_value) for ($row_data->{name},$col_data->{name}) is not numeric.");
      }
    }

    my $cell_data = { col       => $col_data,
		      row       => $row_data,
		      raw_value => $cell_value,
		      missing   => $cell_value_clean eq $CONF{missing_cell_value},
		      value     => $cell_value_clean };

    # handle the case for intra-segment cells (i.e. cells for row/column of the same name)
    if($col_data->{name} eq $row_data->{name}) {
      if(! $CONF{intra_cell_handling} || $CONF{intra_cell_handling} eq "show") {
	# treat this as any other cell
      } elsif ($CONF{intra_cell_handling} eq "hide") {
	printdebug("hiding intra-cell value",$row_data->{name},$col_data->{name},$cell_value);
	$cell_data->{hide} = 1;
      } elsif ($CONF{intra_cell_handling} eq "remove") {
	printdebug("removing intra-cell value",$row_data->{name},$col_data->{name},$cell_value);
	$cell_data->{value} = $CONF{missing_cell_value};
	$cell_data->{missing} = 1;
      }
    }
    printdebug("registered cell value",$row_data->{name},$col_data->{name},$cell_data->{value});
    push @{$table->{cell_list}}, $cell_data;
    $table->{cell}{$row_data->{name}}{$col_data->{name}} = $cell_data;
  }
}

#printdumper($table->{col});exit;
for my $row (@{$table->{row}{list}}) {
  $table->{row}{label}{$row->{name}} = $row;
}
for my $col (@{$table->{col}{list}}) {
  $table->{col}{label}{$col->{name}} = $col;
}

#print Dumper($table);

if($CONF{show_parsed}) {
  report_parse_table($table);
  exit;
}

################################################################
#
# Compile cells statistics based on cleaned (but unfiltered) values

my $stat;
$stat->{cell}{raw} = Statistics::Descriptive::Full->new();
$stat->{cell}{raw}->add_data(map { $_->{value} } grep(! $_->{missing}, @{$table->{cell_list}}));
#printdebug("raw data",$stat->{cell}{raw}->get_data);
printdebug("raw cell stats","min",$stat->{cell}{raw}->min);
printdebug("raw cell stats","average",$stat->{cell}{raw}->mean);
printdebug("raw cell stats","median",$stat->{cell}{raw}->median);
printdebug("raw cell stats","max",$stat->{cell}{raw}->max);

################################################################
#
# Filter the cell values based on min/max value and percentile filters.
# If a cell value does not pass these filters, then it can be either
# hidden or removed. If it is hidden, it won't be shown but the col/row size
# will not be affected. If it is removed, then the result is the same as if
# the cell value was missing in the input file.
#

for my $cell (grep(! $_->{missing}, @{$table->{cell_list}})) {
  my $reject;
  $reject = 1 if defined $CONF{cell_min_value} && $cell->{value} < $CONF{cell_min_value};
  $reject = 1 if defined $CONF{cell_max_value} && $cell->{value} > $CONF{cell_max_value};
  $reject = 1 if defined $CONF{cell_min_percentile} && $cell->{value} < $stat->{cell}{raw}->percentile($CONF{cell_min_percentile});
  $reject = 1 if defined $CONF{cell_max_percentile} && $cell->{value} > $stat->{cell}{raw}->percentile($CONF{cell_max_percentile});
  if($reject && ($cell->{col}{idx} < 15 || $cell->{col}{idx} > 113) ) {
      #printdumper($cell);
    printdebug("filtering out cell ($cell->{row}{name},$cell->{col}{name})=$cell->{value}",$cell->{col}{idx});
    if(! defined $CONF{cutoff_cell_handling} || $CONF{cutoff_cell_handling} eq "hide") {
      $cell->{hide} = 1;
    } elsif ($CONF{cutoff_cell_handling} eq "remove") {
      $cell->{value}   = $CONF{missing_cell_value};
      $cell->{missing} = 1;
    } else {
      report_error("The cutoff_cell_handling value ($CONF{cutoff_cell_handling}) does not correspond to a valid choice (hide,remove)");
    }
  }
}

################################################################
#
# Compile cells statistics based on filtered values - these stats
# will be the same if no cell filters were used.
#

$stat->{cell}{filtered} = Statistics::Descriptive::Full->new();
$stat->{cell}{filtered}->add_data(map { $_->{value} } grep(! $_->{hide} && ! $_->{missing}, @{$table->{cell_list}}));
printdebug("filtered cell stats","min",$stat->{cell}{filtered}->min);
printdebug("filtered cell stats","average",$stat->{cell}{filtered}->mean);
printdebug("filtered cell stats","median",$stat->{cell}{filtered}->median);
printdebug("filtered cell stats","max",$stat->{cell}{filtered}->max);

################################################################
#
# scale cell values
#

for my $cell_data (grep(! $_->{missing}, @{$table->{cell_list}})) {
  my $value_scaled = scale_value($cell_data->{value},$stat->{cell}{raw}->max);
  $cell_data->{scaled_value} = $value_scaled;
  printinfo("scale",$CONF{scaling_type},$cell_data->{value},$value_scaled);
}
my $value_type = $CONF{use_scaling} ? "scaled_value" : "value";

################################################################
#
# Compile cells statistics based on scaled values - these stats
# will be the same if no scaling was applied.

$stat->{cell}{scaled} = Statistics::Descriptive::Full->new();
$stat->{cell}{scaled}->add_data(map { $_->{$value_type} } grep(! $_->{hide} && ! $_->{missing}, @{$table->{cell_list}}));
printdebug("scaled cell stats","min",$stat->{cell}{scaled}->min);
printdebug("scaled cell stats","average",$stat->{cell}{scaled}->mean);
printdebug("scaled cell stats","median",$stat->{cell}{scaled}->median);
printdebug("scaled cell stats","max",$stat->{cell}{scaled}->max);

################################################################
#
# Create colors that encode cell value by percentile
#
# The colors will be determined using the raw, filtered or scaled values, depending
# on the value of the percentile_data_domain parameter (raw, filtered, or scaled).
#

for my $i (0 .. 100/$CONF{percentile_sampling}) {
  my $percentile = $i * $CONF{percentile_sampling};
  report_error("The value for percentile_data_domain must be either 'raw', 'filtered' or 'scaled'. This parameter controls whether original or filtered cell values are used to generate the color palette based on percentile values.") unless grep($CONF{percentile_data_domain} eq $_, (qw(raw filtered scaled)));
  my $value = $stat->{cell}{ $CONF{percentile_data_domain} }->percentile($percentile);
  my $h = map_value($percentile,0,100,$CONF{colors}{h0},$CONF{colors}{h1});
  my $s = map_value($percentile,0,100,$CONF{colors}{s0},$CONF{colors}{s1});
  my $v = map_value($percentile,0,100,$CONF{colors}{v0},$CONF{colors}{v1});
  #my $c = Graphics::ColorObject->new_HSV([ int($h),$s,$v ]);
  my @rgb = rgb_to_rgb255(hsv_to_rgb(int($h),$s,$v));
  printinfo("hsvpercentile",$percentile,int($h),$s,$v);
  printinfo("colorpercentile",sprintf("percentile%05d = %d,%d,%d",$percentile,@rgb));
}

################################################################
#
# report row/col/cell data
#

my $ribbon_variable_check;
for my $type (qw(row col)) {
  for my $data (@{$table->{$type}{list}}) {
    if($CONF{ribbon_variable}) {
      if($type eq "row") {
	if(exists $ribbon_variable_check->{$data->{name}}) {
	  die "Row with name $data->{name} seen twice.";
	} else {
	  $ribbon_variable_check->{$data->{name}}++;
	}
      } else {
	if(! exists $ribbon_variable_check->{$data->{name}}) {
	  die "Your data has a column with name $data->{name} but no row with this name. This row must exist when -ribbon_variable is used. For this data set, you should not be using ratio layout.";
	} else {
	  $ribbon_variable_check->{$data->{name}}--;
	}
      }
    }
    printinfo("table report",$type,
	      join(" ",@{$data}{qw(idx name order)}));
  }
}
if($CONF{ribbon_variable}) {
  if(my @names = grep($_, values %$ribbon_variable_check)) {
    die "You selected ratio layout with -ribbon_variable but not all rows/columns have the same name. For this data set, you should not be using ratio layout. Unmatched names were ".join(" ",@names);
  }
}


for my $cell (@{$table->{cell_list}}) {
  printinfo("table report cell",
	    join(" ",
		 $cell->{row}{idx},
		 $cell->{row}{name},
		 $cell->{col}{idx},
		 $cell->{col}{name},
		 "raw",
		 $cell->{raw_value},
		 "cleaned/remapped",
		 $cell->{value} . ($value_type eq "value" ? "*" : ""),
		 "scaled",
		 $cell->{scaled_value} . ($value_type eq "scaled_value" ? "*" : ""),
		 "missing?",
		 $cell->{missing} || 0,
		 "hidden?",
		 $cell->{hide} || 0));
}

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

################################################################
#
# calculate statistics for row/col/cells based on scaled or cleaned/remapped values
#

my @types = qw(row col);
for my $cell (grep(! $_->{missing}, @{$table->{cell_list}})) {
  for my $type (qw(row col)) {
    my $name = $cell->{$type}{name};
    my $row  = $cell->{row}{name};
    my $col  = $cell->{col}{name};
    $stat->{$type}{$name} ||= Statistics::Descriptive::Full->new();
    $stat->{label}{$name} ||= Statistics::Descriptive::Full->new();
    $stat->{cells}        ||= Statistics::Descriptive::Full->new();
    my $skip;
    if($CONF{ribbon_variable} &&
       exists $table->{cell}{$row}{$col} && exists $table->{cell}{$col}{$row}) {
      if($type eq "row") {
	$stat->{label}{$name}->add_data( $cell->{$value_type} );
	$stat->{$type}{$name}->add_data( $cell->{$value_type} );
      } elsif ($type eq "col") {
	# TODO is this working???
	if($CONF{ribbon_variable_intra_collapse} && $row eq $col) {
	  # do not add to the size of the segment if we're collapsing
	  # intrasegment ribbons
	} else {
	  $stat->{$type}{$name}->add_data( $table->{cell}{$row}{$col}{$value_type});
	}
	#$seen->{labelstat}{$row}{$col}++;
	#$seen->{labelstat}{$col}{$row}++;
      } else {
	#
      }
    } else {
      $stat->{label}{$name}->add_data($cell->{$value_type});
      $stat->{$type}{$name}->add_data($cell->{$value_type});
    }
    $stat->{cells}->add_data( $cell->{$value_type} );
  }
}

for my $stattype (qw(row col label)) {
  for my $name (sort keys %{$stat->{$stattype}}) {
    printinfo("row/col/label stat",$stattype,$name,
	      "sum",
	      $stat->{$stattype}{$name}->sum,
	      "n",
	      $stat->{$stattype}{$name}->count,
	      "min",
	      $stat->{$stattype}{$name}->min,
	      "max",
	      $stat->{$stattype}{$name}->max,
	      "avg",
	      $stat->{$stattype}{$name}->mean);
  }
}

# No longer interested in the cell associated with missing values - remove these
# from the cell list.

@{$table->{cell_list}} = grep(! $_->{missing}, @{$table->{cell_list}});

# Collect a list of all unique labels
my @unique_labels = unique ( map { $_->{row}{name}, $_->{col}{name}} @{$table->{cell_list}} );

# Apply normalization

my $normalization;
if($CONF{use_segment_normalization}) {
  for my $label (@unique_labels) {
    my $norm;
    if($CONF{segment_normalization_function} eq "total") {
      $norm = sum( map {$_->{$value_type}} grep($_->{row}{name} eq $label || $_->{col}{name} eq $label, @{$table->{cell_list}}));
    } elsif($CONF{segment_normalization_function} eq "average") {
      $norm = average( map {$_->{$value_type}} grep($_->{row}{name} eq $label || $_->{col}{name} eq $label, @{$table->{cell_list}}));
    } elsif ($CONF{segment_normalization_function} eq "row_total") {
      $norm = sum( map {$_->{$value_type}} grep($_->{row}{name} eq $label, @{$table->{cell_list}}));
    } elsif ($CONF{segment_normalization_function} eq "row_average") {
      $norm = average( map {$_->{$value_type}} grep($_->{row}{name} eq $label, @{$table->{cell_list}}));
    } elsif ($CONF{segment_normalization_function} eq "col_total") {
      $norm = sum( map {$_->{$value_type}} grep($_->{col}{name} eq $label, @{$table->{cell_list}}));
    } elsif ($CONF{segment_normalization_function} eq "col_average") {
      $norm = average( map {$_->{$value_type}} grep($_->{col}{name} eq $label, @{$table->{cell_list}}));
    } elsif ($CONF{segment_normalization_function} eq "row_size") {
      if(exists $table->{row}{label}{$label}) {
	if(! defined $table->{row}{label}{$label}{size}) {
	  report_error("You asked for normalization based on optional row size column, but no such column was detected.");
	} else {
	  $norm = $table->{row}{label}{$label}{size};
	}
      }
    } elsif ($CONF{segment_normalization_function} eq "col_size") {
      if(exists $table->{col}{label}{$label}) {
	if(! defined $table->{col}{label}{$label}{size}) {
	  report_error("You asked for normalization based on optional col size row, but no such row was detected.");
	} else {
	  $norm = $table->{col}{label}{$label}{size};
	}
      }
    } elsif ($CONF{segment_normalization_function} eq "total_size") {
      if(exists $table->{col}{label}{$label}) {
	if(! defined $table->{col}{label}{$label}{size}) {
	  report_error("You asked for normalization based on optional size values, but no column that stored row sizes was detected.");
	} else {
	  $norm += $table->{col}{label}{$label}{size};
	}
      }
      if(exists $table->{row}{label}{$label}) {
	if(! defined $table->{row}{label}{$label}{size}) {
	  report_error("You asked for normalization based on optional size values, but no row that stored column sizes was detected.");
	} else {
	  $norm += $table->{row}{label}{$label}{size};
	}
      }
    } elsif ($CONF{segment_normalization_function} =~ /(\d+)/) {
      $norm = $1;
    } else {
      report_error("You asked for segment normalization but the segment_normalization_function field value ($CONF{segment_normalization_function}) is one one of the valid choices.");
    }
    printdebug("segment normalization function",$CONF{segment_normalization_function},"segment",$label,"normvalue",$norm);
    $normalization->{$label} = round($norm);
  }
}

# Statistics for normalized cell values

for my $cell (grep(! $_->{missing}, @{$table->{cell_list}})) {
  my $row  = $cell->{row}{name};
  $stat->{cells_norm} ||= Statistics::Descriptive::Full->new();
  my $vn = normvalue($cell->{$value_type},$row);
  printdebug("cellnorm",$row,$cell->{col}{name},$cell->{$value_type},$vn);
  $stat->{cells_norm}->add_data($vn);
}

# compute percentiles

my $ptmp;
for my $value (sort {$a <=> $b} $stat->{cells_norm}->get_data) {
  if($CONF{percentile_method} eq "value") {
    if($CONF{percentile_unique_only}) {
      $ptmp->{$value} = remap_for_percentile($value);
    } else {
      $ptmp->{$value}+= remap_for_percentile($value);
    }
  } else {
    if($CONF{percentile_unique_only}) {
      $ptmp->{$value} = 1;
    } else {
      $ptmp->{$value} ++;
    }
  }
}
my $ctmp;
for my $value (sort {$a <=> $b} keys %$ptmp) {
  my $p;
  if($CONF{percentile_method} eq "value") {
    $ctmp += $ptmp->{$value};
    my $den = sum(values %$ptmp);
    $p = $ctmp / $den;
  } else {
    my $den = sum(values %$ptmp);
    $p = average ($ctmp,$ctmp+$ptmp->{$value}) / $den;
    $ctmp += $ptmp->{$value};
  }
  $stat->{cell_percentile}{$value} = 100*$p;
  printdebug("pstat",$value,remap_for_percentile($value),$p);
}

################################################################
#
# compile a list of unique row/column names and determine the
# order in which corresponding segments will be drawn in the image
#
# each label will correspond to an ideogram (segment) in the figure
#

printdebug("unique labels",@unique_labels);
my @labels = order_labels($CONF{segment_order},@unique_labels);

# register label order

my $label_order;
for my $i ( 0 .. @labels-1) {
  $label_order->{ $labels[$i] } = $i;
}

################################################################
# determine the mapping between row/col names and the names
# of the ideograms in Circos files. If the segment_prefix is set, then
# the ideograms are named segment_prefix + IDX where IDX=0,1,2,3... in the
# order of segments in the image. If the chr-Prefix is not set, then
# the ideograms are named after the label.

my $label2seg;
for my $label_idx (0..@labels-1) {
  if($CONF{segment_prefix}) {
    $label2seg->{ $labels[$label_idx] } = sprintf("%s%d",$CONF{segment_prefix},$label_idx);
  } else {
    $label2seg->{ $labels[$label_idx] } = $labels[$label_idx];
  }
  printinfo("label2seg",$label_idx,$labels[$label_idx],$label2seg->{$labels[$label_idx]});
}

################################################################ 
# compile a list of colors associated with a row/col name

for my $type (qw(row col)) {
  for my $elem (@{$table->{$type}{list}}) {
    if($label_color->{$elem->{name}} && $elem->{color} && $label_color->{$elem->{name}} ne $elem->{color}) {
	#report_error("color for label [$elem->{name}] is already defined to be [$label_color->{$elem->{name}}] but saw new definition [$elem->{color}]");
    } elsif ($elem->{color}) {
      $label_color->{$elem->{name}} = $elem->{color};
      printdebug("assigned color from data file",$elem->{name},$elem->{color});
    }
  }
}

# for row/col names that do not have a specified color, generate
# a color by interpolating 
my @label_for_color;
if($CONF{segment_color_order}) {
  @label_for_color = order_labels($CONF{segment_color_order},grep(! defined $label_color->{$_}, @labels));
} else {
  @label_for_color = grep(! defined $label_color->{$_}, @labels);
}
my $cumul_size = 0;
for my $i (0..@label_for_color-1) {
  my $label = $label_for_color[$i];
  my ($h,$s,$v);
  if($CONF{segment_colors}{interpolate_type} =~ /size/) {
    my $total_label_size = sum ( map { normvalue($stat->{label}{$_}->sum,$_) } @label_for_color );
    $total_label_size -= normvalue($stat->{label}{ $label_for_color[0] }->sum, $label_for_color[0])/2;
    $total_label_size -= normvalue($stat->{label}{ $label_for_color[-1] }->sum, $label_for_color[-1])/2;
    if($cumul_size) {
      $cumul_size += normvalue($stat->{label}{$label}->sum,$label)/2;
    }
    my $x = $cumul_size / $total_label_size;
    $h = map_value($x,0,1,$CONF{segment_colors}{h0},$CONF{segment_colors}{h1});
    $s = map_value($x,0,1,$CONF{segment_colors}{s0},$CONF{segment_colors}{s1});
    $v = map_value($x,0,1,$CONF{segment_colors}{v0},$CONF{segment_colors}{v1});
    $cumul_size += normvalue($stat->{label}{$label}->sum,$label)/2;
  } else {
    $h = map_value($i,0,@label_for_color-1,$CONF{segment_colors}{h0},$CONF{segment_colors}{h1});
    $s = map_value($i,0,@label_for_color-1,$CONF{segment_colors}{s0},$CONF{segment_colors}{s1});
    $v = map_value($i,0,@label_for_color-1,$CONF{segment_colors}{v0},$CONF{segment_colors}{v1});
  }
  printdebug("interpolated hsv for segment",$h,$s,$v);
  #my $c = Graphics::ColorObject->new_HSV([ $h,$s,$v ]);
  my @rgb = rgb_to_rgb255(hsv_to_rgb(int($h),$s,$v));
  $label_color->{$label_for_color[$i]} = join(",",@rgb);
  printdebug("assigned color from interpolated range",$label_for_color[$i],join(",",@rgb));
}

################################################################
#
# create new color definitions

for my $label (keys %$label_color) {
    if($label2seg->{$label}) {
	printinfo(sprintf("colordef %s%s = %s",lc $CONF{color_prefix},lc $label2seg->{$label},$label_color->{$label}));
    }
}

################################################################
#
# create highlights based on row and column values
#

for my $type (qw(row col)) {
  my $atype = $type eq "row" ? "col" : "row";
  # create a hash of all cell values that lead from $type/label combination (e.g. row/A)
  # to $atype/label combination (e.g. col/B)
  my %values;
  for my $label (keys %{$table->{$type}{label}}) {
    for my $cell (@{$table->{cell_list}}) {
      if($cell->{$type}{name} eq $label) {
	$values{$label}{$cell->{$atype}{name}} = $cell->{$value_type};
      }
    }
  }

  for my $label ( keys %values ) {
    my $cumul_pos = 0;
    my $total_sum = sum( values %{$values{$label}} );
    for my $alabel ( sort {$values{$label}{$b} <=> $values{$label}{$a}} keys %{$values{$label}} ) {
      my $norm_factor = $CONF{normalize_contribution} ? fetch_segment_size($label) / $total_sum : 1;
      printinfo(sprintf("%s %s %s%s %.0f %.0f fill_color=%s%s%s",
			"highlight",
			$type,
			$CONF{segment_prefix},
			$label2seg->{ $label },
			$norm_factor * $cumul_pos,
			$norm_factor * ($cumul_pos + $values{$label}{$alabel}),
			lc $CONF{color_prefix},
			lc $CONF{segment_prefix},
			lc $label2seg->{$alabel}));
      $cumul_pos += $values{$label}{$alabel};
    }
  }
}

# create combined row/col highlights
for my $label (@labels) {
  my $cumul_pos = 0;
  my %values;
  for my $cell (@{$table->{cell_list}}) {
    if($cell->{row}{name} eq $label) {
      $values{$cell->{col}{name}} += $cell->{$value_type};
    }
    if ($cell->{col}{name} eq $label) {
      $values{$cell->{row}{name}} += $cell->{$value_type};
    }
  }
  die "label stat for label [$label] not defined" if ! defined $stat->{label}{$label};
  my $sum = $stat->{label}{$label}->sum;
  my $norm_factor = $CONF{normalize_contribution} ? fetch_segment_size($label) / $sum : 1;
  for my $alabel ( sort {$values{$b} <=> $values{$a}} keys %values ) {
    printinfo(sprintf("%s %s %s%s %.0f %.0f fill_color=%s%s%s",
		      "highlight",
		      "all",
		      $CONF{segment_prefix},
		      $label2seg->{ $label },
		      $norm_factor * $cumul_pos,
		      $norm_factor * ($cumul_pos + $values{$alabel}),
		      lc $CONF{color_prefix},
		      lc $CONF{segment_prefix},
		      lc $label2seg->{$alabel}));
    $cumul_pos += $values{$alabel};
  }
}

################################################################
#
# generate segment sizes and coordinates for each row/col label
#
# this information is passed to Circos using the karyotype parameter

for my $label ( @labels ) {
  my $size = normvalue($stat->{label}{$label}->sum,$label);
  # if this row/col has a specific size, use it
  if(exists $table->{row}{label}{$label} && $table->{row}{label}{$label}{size}) {
    $size = $table->{row}{label}{$label}{size};
  } elsif (exists $table->{col}{label}{$label} && $table->{col}{label}{$label}{size}) {
    $size = $table->{col}{label}{$label}{size};
  }
  $size = fetch_segment_size($label);
  next unless $size;
  printinfo("karyotype",
	    sprintf("chr - %s %s 0 %.0f %s%s",
		    $label2seg->{$label},
		    $label2seg->{$label},
		    $size,
		    lc $CONF{color_prefix},
		    lc $label2seg->{$label}));
  (my $text_label = $label) =~ s/ /:/g;
  $text_label = uc $text_label if $CONF{segment_label_uppercase};
  if($CONF{segment_label_size_range}) {
    my ($min_size,$max_size) = split(/,/,$CONF{segment_label_size_range});
    my $min_label = min( map {normvalue($stat->{label}{$_}->sum,$_)} @labels);
    my $max_label = max( map {normvalue($stat->{label}{$_}->sum,$_)} @labels);
    my $label_size;
    if($max_label - $min_label) {
      my $k = $CONF{segment_label_size_progression} || 1;
      $label_size = $min_size + ($max_size-$min_size)*((normvalue($stat->{label}{$label}->sum,$label) - $min_label)/($max_label-$min_label))**(1/$k);
    } else {
      $label_size = $max_size;
    }
    printinfo("segmentlabel",
	      sprintf("%s %s %s %s label_size=%dp",
		      $label2seg->{$label},
		      #$size/2,
		      #$size/2,
		      0,
		      $size,
		      $text_label,$label_size));
  } else {
    printinfo("segmentlabel",
	      sprintf("%s %s %s %s",
		      $label2seg->{$label},
		      0,
		      $size,
		      $text_label));
  }
}

################################################################
# if segment normalization is done by Circos (i.e. values are not
# remapped, but segments are scaled visually), then report a line
# that gives the segment scaling

# report scaling line
my @chromosomes_scale;
for my $label (@labels) {
  my $scale = 1;
  # include the third force parameter to force normalization
  if($CONF{use_segment_normalization} && $CONF{segment_normalization_scheme} eq "visual") {
    my $orig_size = $stat->{label}{$label}->sum;
    my $norm_size = normvalue($stat->{label}{$label}->sum,$label,1);
    $scale = $norm_size / $orig_size;
    printinfo("scaling",
	      sprintf("%s pre %d norm %d scale %.3f",
		      $label2seg->{$label},
		      $orig_size,
		      $norm_size,
		      $scale));
  }
  push @chromosomes_scale, sprintf("%s:%.4f",$label2seg->{$label},$scale);
}
printinfo("chromosomes_scale =",join(",",@chromosomes_scale));

################################################################
#
# assign segment position for each cell
#

my $pos;
my $assigned;

my @loop1 = $CONF{ribbon_variable} ? split(/,/,$CONF{placement_order}) : @labels;
my @loop2 = $CONF{ribbon_variable} ? @labels : split(/,/,$CONF{placement_order});

# ribbon-variable = yes
# loop1 = row | col
# loop2 = label
# ribbon-variable = no
# loop1 = label
# loop2 = row | col

for my $loop1 (@loop1) {
  for my $loop2 (@loop2) {
    printinfo("loop",$loop1,$loop2);
    my ($label,$type) = $CONF{ribbon_variable} ? ($loop2,$loop1) : ($loop1,$loop2);
    # $atype is the corresponding table object for the given $type
    # $type=row $atype=col
    # $type=col $atype=row
    my $atype = $type eq "row" ? "col" : "row";

    my @cells = grep(! $_->{missing} && $_->{$type}{name} eq $label, @{$table->{cell_list}});
    my @cells_sorted;
    if($CONF{ribbon_bundle_order} =~ /size_desc/) {
      @cells_sorted =  sort {$b->{$value_type} <=> $a->{$value_type}} @cells;
    } elsif ($CONF{ribbon_bundle_order} =~ /size_asc/) {
      @cells_sorted =  sort {$a->{$value_type} <=> $b->{$value_type}} @cells;
    } elsif ($CONF{ribbon_bundle_order} =~ /ascii/) {
      @cells_sorted =  sort {$a->{$atype}{name} cmp $b->{$atype}{name}} @cells;
    } elsif ($CONF{ribbon_bundle_order} =~ /native/) {
      # TODO - make sure this option is working correctly
      @cells_sorted =  sort {$label_order->{$b->{$atype}{name}} <=> $label_order->{$a->{$atype}{name}}} @cells;
    } else {
      die "ribbon_bundle_order value [$CONF{ribbon_bundle_order}] not supported";
    }

    for my $cell (@cells_sorted) {

      my $row = $cell->{row}{name};
      my $col = $cell->{col}{name};
      my $value_norm = normvalue($cell->{$value_type},$label); 

      printdebug("processing cell ($row,$col)=",$value_norm,"end $type");

      if( ($type eq "row" && $CONF{reverse_rows})
	  ||
	  ($type eq "col" && $CONF{reverse_columns})
	) {
	$pos->{$label} ||= normvalue($stat->{label}{$label}->sum,$label);
	$cell->{$type."_end"}   = $pos->{$label} || 0;
	$cell->{$type."_start"} = $pos->{$label} - $value_norm;
	$pos->{$label} = $cell->{$type."_start"};
	$assigned->{$row}{$col}++;
      } else {
	if($CONF{ribbon_variable}) {
	  if($type eq "row") {
	    if($assigned->{$col}{$row}) {
	      my $tcell = $table->{cell}{$col}{$row};
	      printdebug("transposeinfo",$col,$row);
	      if($col eq $row) {
		$tcell->{"col_start"} = $tcell->{"row_end"};
		$tcell->{"col_end"}   = $tcell->{"row_end"};
	      } else {
		#$value_norm = normvalue($tcell->{$value_type},$label);
		$tcell->{$atype."_start"} = $pos->{$label} || 0;
		$tcell->{$atype."_end"}   = $tcell->{$atype."_start"} + $value_norm;
		$pos->{$label} = $tcell->{$atype."_end"};
		$assigned->{$col}{$row}++;
		#printdumper($tcell);
	      }
	    } else {
	      $cell->{$type."_start"} = $pos->{$label} || 0;
	      $cell->{$type."_end"}   = $cell->{$type."_start"} + $value_norm;
	      $pos->{$label} = $cell->{$type."_end"};
	      $assigned->{$row}{$col}++;
	    }
	  } else { 
	    if($row eq $col) {
	      $cell->{"col_start"} = $cell->{"row_end"};
	      $cell->{"col_end"}   = $cell->{"row_end"};
	    }
	  }
	} else {
	  $cell->{$type."_start"} = $pos->{$label} || 0;
	  $cell->{$type."_end"}   = $cell->{$type."_start"} + $value_norm;
	  $pos->{$label} = $cell->{$type."_end"};
	  $assigned->{$row}{$col}++;
	}
      }
      printdebug("cellinfo",$type,$row,$col,
		 "row",defor($cell->{row_start},"-"),defor($cell->{row_end},"-"),
		 "col",defor($cell->{col_start},"-"),defor($cell->{col_end},"-"));
      printdebug("posinfo",
		 map { sprintf("%s %d",$_,$pos->{$_}) } @labels);
    }
  }
}

my @cell_values = map { $_->{$value_type} } grep(! $_->{missing}, @{$table->{cell_list}});

my $linkid=0;

for my $cell ( grep(! $_->{missing} && ! $_->{hide}, @{$table->{cell_list}}) ) {

  next unless defined $cell->{"row_end"} && defined $cell->{"col_end"};
  next unless $cell->{$value_type};

  my $row = $cell->{row}{name};
  my $col = $cell->{col}{name};
  
  printdebug("drawinginfo",$cell->{row}{name},$cell->{col}{name});
  
  my $z;
  if($CONF{ribbon_layer_order} eq "size_desc") {
    $z = map_value($cell->{$value_type},scalar(min(@cell_values)),scalar(max(@cell_values)),100,0);
  } else {
    $z = map_value($cell->{$value_type},scalar(min(@cell_values)),scalar(max(@cell_values)),0,100);
  }
  my %param = (z=>round($z),
	       %{$CONF{linkparam}},
	      );

  my $value_for_percentile;

  if($CONF{ribbon_variable}) {
    my $label;
    my $vrc = normvalue($table->{cell}{$row}{$col}{$value_type},$row);
    my $vcr = normvalue($table->{cell}{$col}{$row}{$value_type},$col);
    if($CONF{linkcolor}{color_source} =~ /large/) {
      $label = $vrc >= $vcr ? $row : $col;
      $value_for_percentile = $vrc;
    } elsif ($CONF{linkcolor}{color_source} =~ /small/) {
      $label = $vrc <= $vcr ? $row : $col;
      $value_for_percentile = $vrc;
    } elsif ($CONF{linkcolor}{color_source} =~ /row/) {
      $label = $row;
      $value_for_percentile = $vrc;
    } elsif ($CONF{linkcolor}{color_source} =~ /col/) {
      $label = $col;
      $value_for_percentile = $vcr;
    } else {
      die "Cannot understand color_source parameter [$CONF{linkcolor}{color_source}] when ribbon_variable=yes";
    }
    if($CONF{linkcolor}{percentile_source} =~ /large/) {
      $value_for_percentile = $vrc >= $vcr ? $vrc : $vcr;
    } elsif ($CONF{linkcolor}{percentile_source} =~ /small/) {
      $value_for_percentile = $vrc <= $vcr ? $vrc : $vcr;
    } elsif ($CONF{linkcolor}{percentile_source} eq "row") {
      $value_for_percentile = $vrc;
    } elsif ($CONF{linkcolor}{percentile_source} eq "col") {
      $value_for_percentile = $vcr;
    } else {
      die "Cannot understand percentile_source parameter [$CONF{linkcolor}{percentile_source}] when ribbon_variable=yes";
    }
    $param{color} = lc sprintf("%s%s",$CONF{color_prefix},$label2seg->{$label});
  } else {
    $value_for_percentile = normvalue($table->{cell}{$row}{$col}{$value_type},$row);
    if($CONF{linkcolor}{color_source}) {
      $param{color} = lc sprintf("%s%s",$CONF{color_prefix},$label2seg->{$cell->{$CONF{linkcolor}{color_source}}{name}}),
    }
  }

  $param{color} = change_transparency($param{color},$CONF{linkcolor}{color_transparency}) if exists $CONF{linkcolor}{color_transparency};

  if($CONF{linkcolor}{color_remap}) {
    if($CONF{linkcolor}{percentile} && ! $CONF{linkcolor}{color_autoremap}) {
      for my $p (sort {$a <=> $b} keys %{$CONF{linkcolor}{percentile}}) {
	my $v = $value_for_percentile;
	if($stat->{cell_percentile}{$v} < $p || $p == 100) {
	  printdebug("pcremap",$row,$col,$v,$stat->{cell_percentile}{$v},$p);
	  for my $param (sort keys %{$CONF{linkcolor}{percentile}{$p}}) {
	    my $value = $CONF{linkcolor}{percentile}{$p}{$param};
	    if($param =~ /transparency/) {
	      if($value == 0) {
		$param{color} =~ s/_a\d+//;
	      } elsif ($param{color} =~ /_a\d+/) {
		  $param{color} =~ s/_a\d+/_a$value/;
	      } else {
		$param{color} .= sprintf("_a%d",$value);
	      }
	    } else {
	      $param{$param} = $value;
	    }
	  }
	  last;
	}
      }
    } elsif ($CONF{linkcolor}{value} && ! $CONF{linkcolor}{color_autoremap}) {
      for my $value (sort {$a <=> $b} keys %{$CONF{linkcolor}{value}}) {
	if ($cell->{$value_type} <= $value) {
	  for my $param (sort keys %{$CONF{linkcolor}{value}{$value}}) {
	    my $value = $CONF{linkcolor}{value}{$value}{$param};
	    if($param =~ /transparency/) {
	      if($value == 0) {
		$param{color} =~ s/_a\d+//;
	      } elsif ($param{color} =~ /_a\d+/) {
		  $param{color} =~ s/_a\d+/_a$value/;
	      } else {
		$param{color} .= sprintf("_a%d",$value);
	      }
	    } else {
	      $param{$param} = $value;
	    }
	  }
	  last;
	}
      }
    } else {
      my $v = $value_for_percentile;
      my $cell_percentile = $stat->{cell_percentile}{$v};
      $param{color} = sprintf("percentile%05d",$CONF{percentile_sampling}*int($cell_percentile/$CONF{percentile_sampling}));
      printinfo("percentile remap",$v,$cell_percentile,$CONF{percentile_sampling}*int($cell_percentile/$CONF{percentile_sampling}),$param{color});
    }
  }
  
  if($cell->{$value_type} < $stat->{cell}{raw}->percentile(25)) {
    $param{color} = $CONF{cell_q1_color} if $CONF{cell_q1_color};
    $param{stroke_thickness} = "0" if $CONF{cell_q1_nostroke};
    $param{color} = change_transparency($param{color},$CONF{linkcolor}{color_transparency}) if exists $CONF{linkcolor}{color_transparency};
    $param{color} = change_transparency($param{color},$CONF{cell_q1_transparency}) if exists $CONF{cell_q1_transparency};
  } elsif ($cell->{$value_type} < $stat->{cell}{raw}->percentile(50)) {
    $param{color} = $CONF{cell_q2_color} if $CONF{cell_q2_color};
    $param{stroke_thickness} = "0" if $CONF{cell_q2_nostroke};
    $param{color} = change_transparency($param{color},$CONF{linkcolor}{color_transparency}) if exists $CONF{linkcolor}{color_transparency};
    $param{color} = change_transparency($param{color},$CONF{cell_q2_transparency}) if exists $CONF{cell_q2_transparency};
  } elsif ($cell->{$value_type} < $stat->{cell}{raw}->percentile(75)) {
    $param{color} = $CONF{cell_q3_color} if $CONF{cell_q3_color};
    $param{stroke_thickness} = "0" if $CONF{cell_q3_nostroke};
    $param{color} = change_transparency($param{color},$CONF{linkcolor}{color_transparency}) if exists $CONF{linkcolor}{color_transparency};
    $param{color} = change_transparency($param{color},$CONF{cell_q3_transparency}) if exists $CONF{cell_q3_transparency};
  } elsif ($cell->{$value_type} <= $stat->{cell}{raw}->percentile(100)) {
    $param{color} = $CONF{cell_q4_color} if $CONF{cell_q4_color};
    $param{stroke_thickness} = "0" if $CONF{cell_q4_nostroke};
    $param{color} = change_transparency($param{color},$CONF{linkcolor}{color_transparency}) if exists $CONF{linkcolor}{color_transparency};
    $param{color} = change_transparency($param{color},$CONF{cell_q4_transparency}) if exists $CONF{cell_q4_transparency};
  }

  printinfo("link",
	    sprintf("cell_%04d %s %.0f %.0f %s",
		    $linkid,
		    $label2seg->{ $cell->{row}{name} },
		    $cell->{row_start},
		    $cell->{row_end},
		    join(",", map {sprintf("%s=%s",$_,$param{$_})} keys %param)
		   ));

  printinfo("link",
	    sprintf("cell_%04d %s %.0f %.0f %s",
		    $linkid,
		    $label2seg->{ $cell->{col}{name} },
		    $cell->{col_start},
		    $cell->{col_end},
		    join(",", map {sprintf("%s=%s",$_,$param{$_})} keys %param)
		   ));

  printinfo("colribboncap",
	    sprintf("%s %.0f %.0f fill_color=%s%s",
		    $label2seg->{ $cell->{col}{name} },
		    $cell->{col_start},
		    $cell->{col_end},
		    lc $CONF{color_prefix},
		    lc $label2seg->{ $cell->{row}{name} }
		   ));

  printinfo("rowribboncap",
	    sprintf("%s %.0f %.0f fill_color=%s%s",
		    $label2seg->{ $cell->{row}{name} },
		    $cell->{row_start},
		    $cell->{row_end},
		    lc $CONF{color_prefix},
		    lc $label2seg->{ $cell->{col}{name} }
		   ));

  $linkid++;
}

report_error("could not parse any cell values to draw") if ! $linkid;

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

sub hsv_to_rgb {
	my ($h, $s, $v) = @_;
	my @rgb;
	
	$h = $h % 360 if $h < 0 || $h > 360;
	# hue segment 
	$h /= 60;
	
	my $i = POSIX::floor( $h );
	my $f = $h - $i; 
	my $p = $v * ( 1 - $s );
	my $q = $v * ( 1 - $s * $f );
	my $t = $v * ( 1 - $s * ( 1 - $f ) );
	
	if ($i == 0) {
		@rgb = ($v,$t,$p);
	} elsif ($i == 1) {
		@rgb = ($q,$v,$p);
	} elsif ($i == 2) {
		@rgb = ($p,$v,$t);
	} elsif ($i == 3) {
		@rgb = ($p,$q,$v);
	} elsif ($i == 4) {
		@rgb = ($t,$p,$v);
	} else {
		@rgb = ($v,$p,$q);
	}
	return @rgb;
}

sub rgb_to_rgb255 {
	my @rgb = @_;
	# make sure values are in [0,1]
	@rgb = map { put_between($_,0,1) } @rgb;
	my @rgb255 = map { round( 255 * $_) } @rgb;
	return @rgb255;
}

sub put_between {
	my ($x,$min,$max) = @_;
	return $min if $x < $min;
	return $max if $x > $max;
	return $x;
}

sub change_transparency {
  my ($color,$t) = @_;
  if($color =~ /(.+)_a\d+/) {
    if($t) {
      return sprintf("%s_a%d",$1,$t);
    } else {
      return $1;
    }
  } else {
    if($t) {
      return sprintf("%s_a%d",$color,$t);
    } else {
      return $color;
    }
  }
}

sub fetch_segment_size {
  my $label = shift;
  my $size = normvalue($stat->{label}{$label}->sum,$label);
  # if this row/col has a specific size, use it
  if(exists $table->{row}{label}{$label} && $table->{row}{label}{$label}{size}) {
    $size = $table->{row}{label}{$label}{size};
  } elsif (exists $table->{col}{label}{$label} && $table->{col}{label}{$label}{size}) {
    $size = $table->{col}{label}{$label}{size};
  }
  return $size;
}

sub report_parse_table {
  my $table = shift;
  my @lines;
  push @lines,["data",map {$_->{name}} @{$table->{col}{list}}];
  for my $row (@{$table->{row}{list}}) {
    push @lines, [$row->{name}];
    for my $col (@{$table->{col}{list}}) {
      push @{$lines[-1]},$table->{cell}{$row->{name}}{$col->{name}}{raw_value};
    }
  }
  my @strings = 
  my $max_length = max (map {length($_)} (map {@$_} @lines) );
  for my $line (@lines) {
    printf("%${max_length}s "x@lines . "\n",@$line);
  }
  
}

sub remap_for_percentile {
  my $value = shift;
  if($CONF{percentile_remap}) {
    (my $cmd = $CONF{percentile_remap}) =~ s/X/$value/g;
    $cmd = eval $cmd;
    die "could not parse the percentile remap function $CONF{percentile_remap} with error [$@]" if $@;
    return $cmd;
  } else {
    return $value;
  }
}

sub defor {
  my $value = shift;
  my $or    = shift;
  return defined $value ? $value : $or;
}

sub order_labels {
  my ($scheme,@unique_labels) = @_;
  # first, add labels for which a label order exists
  my @labels_preorder = sort {$segment_order->{$a} <=> $segment_order->{$b}} grep(defined $segment_order->{$_}, @unique_labels);
  printdebug("label order preorder",@labels_preorder);
  # now deal with remaining labels
  my @labels_to_order = grep(! defined $segment_order->{$_}, @unique_labels);
  my @labels_row = grep( $table->{row}{label}{$_}, @labels_to_order);
  my @labels_col = grep( $table->{col}{label}{$_}, @labels_to_order);
  my @labels_ordered;
  printdebug("label order scheme",$scheme);
  if($scheme =~ /file:(.*)/) {
    my $file = $1;
    open(F,$file) || report_error("Cannot open segment order file ($file).");
    while(<F>) {
      chomp;
      my $segment = $_;
      if(! grep($segment eq $_, @labels_to_order)) {
	#report_error("You asked that segments be ordered using the file ($file) and the segment in the file ($segment) does not correspond to any row/col name that requires ordering.");
      } else {
	push @labels_ordered, $segment;
      }
    }
    close(F);
  } elsif ($scheme =~ /ascii/) {
    if($scheme =~ /row_major/) {
      @labels_ordered = unique (  ( sort @labels_row ), ( sort @labels_col ) );
    } elsif ($scheme =~ /col_major/) {
      @labels_ordered = unique (  ( sort @labels_col ), ( sort @labels_row ) );
    } elsif ($scheme =~ /size_desc/) {
      @labels_ordered = unique ( sort {$b cmp $a} (@labels_row,@labels_col) );
    } else {
      @labels_ordered = unique ( sort {$a cmp $b} (@labels_row,@labels_col) );
    }
  } elsif ($scheme =~ /size_asc/) {
    if($scheme =~ /row_major/) {
      @labels_ordered = unique (  ( sort {$stat->{label}{$a}->sum <=> $stat->{label}{$b}->sum} @labels_row ),
				  ( sort {$stat->{label}{$a}->sum <=> $stat->{label}{$b}->sum} @labels_col ) );
    } elsif ($scheme =~ /col_major/) {
      @labels_ordered = unique (  ( sort {$stat->{label}{$a}->sum <=> $stat->{label}{$b}->sum} @labels_col ),
				  ( sort {$stat->{label}{$a}->sum <=> $stat->{label}{$b}->sum} @labels_row ) );
    } elsif ($scheme =~ /row_size/) {
      @labels_ordered = unique (  sort {$stat->{row}{$a}->sum <=> $stat->{row}{$b}->sum} @labels_to_order );
    } elsif ($scheme =~ /col_size/) {
      @labels_ordered = unique (  sort {$stat->{col}{$a}->sum <=> $stat->{col}{$b}->sum} @labels_to_order);
    } elsif ($scheme =~ /row_to_col_ratio/) {
      @labels_ordered = unique (  sort { safe_divide($stat->{row}{$a}->sum,$stat->{col}{$a}->sum) <=> safe_divide($stat->{row}{$b}->sum,$stat->{col}{$b}->sum)} @labels_to_order );
    } elsif ($scheme =~ /col_to_row_ratio/) {
      @labels_ordered = unique (  sort { safe_divide($stat->{col}{$a}->sum,$stat->{row}{$a}->sum) <=> safe_divide($stat->{col}{$b}->sum,$stat->{row}{$b}->sum)} @labels_to_order );
    } else {
      @labels_ordered = unique (  ( sort {$stat->{label}{$a}->sum <=> $stat->{label}{$b}->sum} (@labels_row,@labels_col)) );
    }
  } elsif ($scheme =~ /size_desc/) {
    if($scheme =~ /row_major/) {
      @labels_ordered = unique (  ( sort {$stat->{label}{$b}->sum <=> $stat->{label}{$a}->sum} @labels_row ),
				  ( sort {$stat->{label}{$b}->sum <=> $stat->{label}{$a}->sum} @labels_col ) );
    } elsif ($scheme =~ /col_major/) {
      @labels_ordered = unique (  ( sort {$stat->{label}{$b}->sum <=> $stat->{label}{$a}->sum} @labels_col ),
				  ( sort {$stat->{label}{$b}->sum <=> $stat->{label}{$a}->sum} @labels_row ) );
    } elsif ($scheme =~ /row_size/) {
      @labels_ordered = unique (  sort {$stat->{row}{$b}->sum <=> $stat->{row}{$a}->sum} @labels_to_order );
    } elsif ($scheme =~ /col_size/) {
      @labels_ordered = unique (  sort {$stat->{col}{$b}->sum <=> $stat->{col}{$a}->sum} @labels_to_order );
    } elsif ($scheme =~ /row_to_col_ratio/) {
      @labels_ordered = unique (  sort { safe_divide($stat->{row}{$b}->sum/$stat->{col}{$b}->sum) <=> safe_divide($stat->{row}{$a}->sum/$stat->{col}{$a}->sum)} @labels_to_order );
    } elsif ($scheme =~ /col_to_row_ratio/) {
      @labels_ordered = unique (  sort { safe_divide($stat->{col}{$b}->sum,$stat->{row}{$b}->sum) <=> safe_divide($stat->{col}{$a}->sum,$stat->{row}{$a}->sum)} @labels_to_order );
    } else {
      @labels_ordered = unique (  ( sort {$stat->{label}{$b}->sum <=> $stat->{label}{$a}->sum} (@labels_row,@labels_col)) );
    }
  } elsif ($scheme =~ /row_major/) {
    if($scheme =~ /size_desc/) {
      @labels_ordered = unique ( sort {$b cmp $a } ( @labels_row, @labels_col ))
    } else {
      @labels_ordered = unique ( sort {$a cmp $b } ( @labels_row, @labels_col ))
    }
  } elsif ($scheme =~ /col_major/) {
    if($scheme =~ /size_desc/) {
      @labels_ordered = unique ( sort {$b cmp $a} (@labels_col, @labels_row ));
    } else {
      @labels_ordered = unique ( sort {$a cmp $b} (@labels_col, @labels_row ));
    }
  } else {
    die "don't understand segment_order value [$scheme]";
  }
  my @labels = (@labels_preorder,@labels_ordered);
  printinfo("labels ordered",@labels);

  #for my $l (@labels) {
  #  printinfo("labelorder",$l,safe_divide($stat->{row}{$l}->sum,$stat->{col}{$l}->sum),$stat->{row}{$l}->sum,$stat->{col}{$l}->sum);
  #}

  return @labels;
}

# return a normalized value for a row/col label
#
# the normalization is previously determined based on the *_segment_normalization_* parameter
# values. the un-normalized denominator for the label is $stat->{label}{$label}->sum
sub normvalue {
  my ($value,$label,$force) = @_;
  if($normalization->{$label} && ($force || $CONF{segment_normalization_scheme} eq "value")) {
    return $normalization->{$label} * safe_divide($value,$stat->{label}{$label}->sum);
  } else {
    return $value;
  }
}

# linearly remap a $value which falls in range $vmin-$vmax onto 
# the range given by $tmin-$tmax so that
#
# $vmin -> $tmin
# $vmax -> $tmax
sub map_value {
  my ($value,$vmin,$vmax,$tmin,$tmax) = @_;
  if($vmax != $vmin) {
    return $tmin + ($tmax-$tmin)*($value-$vmin)/($vmax-$vmin);
  } else {
    return $tmin;
  }
}

sub safe_divide {
  my ($a,$b) = @_;
  return $b ? $a/$b : 0;
}

sub limit_array_size {
  my $max   = shift;
  my @array = @_;
  if(@_ <= $max) {
    return @_;
  } else {
    return splice(@_,0,$max);
  }
}

sub scale_value {
  my ($v,$vm) = @_;
  my $vscaled;
  return $v if ! $CONF{use_scaling};
  if($CONF{scaling_type} eq "atten_small") {
    my $k = (exp($CONF{scale_factor}*$v/$vm)-exp(0)) / (exp($CONF{scale_factor})-exp(0));
    $vscaled = $k * $vm;
  } else {
    if($v && $vm) {
      my $k = log($v*$CONF{scale_factor})/log($vm*$CONF{scale_factor});
      $vscaled = $k * $vm;
    } else {
      $vscaled = 0;
    }
  }
  #printinfo("factor",$v,$v/$vm,$k);
  return $vscaled;
}

sub unique {
  my %seen;
  my @new;
  for my $elem (@_) {
    push @new, $elem if ! $seen{$elem}++;
  }
  return @new;
}

sub validateconfiguration {
  $CONF{data_mult}      ||= 1;
  $CONF{color_idx_mult} ||= 1;

  $CONF{colors}{h0} = $CONF{percentile_hue_start} if defined $CONF{percentile_hue_start};
  $CONF{colors}{h1} = $CONF{percentile_hue_end} if defined $CONF{percentile_hue_end};

  $CONF{colors}{s0} = $CONF{percentile_saturation_start} if defined $CONF{percentile_saturation_start};
  $CONF{colors}{s1} = $CONF{percentile_saturation_end} if defined $CONF{percentile_saturation_end};

  $CONF{colors}{v0} = $CONF{percentile_brightness_start} if defined $CONF{percentile_brightness_start};
  $CONF{colors}{v1} = $CONF{percentile_brightness_end} if defined $CONF{percentile_brightness_end};

  $CONF{linkcolor}{color_remap}     ||= $CONF{color_remap};
  $CONF{linkcolor}{color_autoremap} ||= $CONF{color_autoremap};

  $CONF{linkcolor}{color_transparency} = $CONF{transparency} if exists $CONF{transparency};
  $CONF{linkcolor}{color_source} = $CONF{color_source} if exists $CONF{color_source};

  $CONF{segment_colors}{interpolate_type} = $CONF{interpolate_type} if exists $CONF{interpolate_type};
}

sub report_error {
  my $msg = shift;
  my $line = shift;
  print STDERR uc "error parsing your table file\n \n";
  print STDERR "problem: $msg\n \n";
  if(defined $line) {
    print STDERR "offending line was\n";
    print STDERR $line,"\n";
  }
  die if $CONF{strict_sanity};
}

sub report_warning {
  my $msg = shift;
  my $line = shift;
  print STDERR "WARNING $msg\n";
}

################################################################
#
# *** 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 printdumper {
  printinfo(Dumper(@_));
}

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

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

sub printdumper {
  printinfo(Dumper(@_));
}