#!/usr/bin/perl
# -*- Mode: perl -*-
# file: qtl

use lib '/usr/local/gramene/lib/perl/';
use strict;
use vars qw($DB);
use Ace 1.51;
use Ace::Browser::AceSubs qw(:DEFAULT Toggle);
use GrameneSubs;
use CGI 2.42 qw/:standard :html3 escape *table *TR *td *blockquote/;

use constant CLASS   => 'QTL';
#use constant EXAMPLE => 'qrAC-1-1';

# open the database
$DB = OpenDatabase() || AceError("Couldn't open database.");

my ($obj_name, $obj);
$obj_name = param('name');
$obj = get_obj($obj_name) if $obj_name;

my $label = $obj->Trait if $obj;

PrintTop($obj,CLASS,$obj ? CLASS . ": $obj ($label)" : CLASS . " Search");
PrintWarning($obj_name,CLASS) if $obj_name && !$obj;
print_report($obj) if $obj;
PrintBottom();

sub get_obj {
  my $name = shift;
  my ($obj) = $DB->fetch(-class =>CLASS,
			 -name  => $name);
  return $obj;
}

sub print_report {
  my $obj = shift;
  print_study_information($obj);
  print_qtl_information($obj);
}

sub print_study_information {
  my $obj = shift;
  my $study = $obj->Qtl_study or return;

  print h2('Study Information');

  print start_table({-border=>1});

  if (my $a = $study->Locality) {
    print TR(
	   th({-class=>'datatitle'},'Locality'),
	   td({-class=>'databody'},$a)
	   );
  }

  if (my $a = $study->Taxon) {
    print TR(
	   th({-class=>'datatitle'},'Taxon'),
 	   td({-class=>'databody'},ObjectLink($a))
	   );
  }
  if ((my $a = $study->Female_parent) && (my $b = $study->Male_parent)) {
    print TR(
	   th({-class=>'datatitle'},'Cross (Male x Female)'),
 	   td({-class=>'databody'},ObjectLink($a),'x',ObjectLink($b))
	    );
  }
  if ((my $a = $study->Population)) {
    print TR(
	   th({-class=>'datatitle'},'Population'),
 	   td({-class=>'databody'},$a)
	    );
  }
  if (my @r = $study->Reference) {
    print TR(
	   th({-class=>'datatitle'},'Reference(s)'),
	   td({-class=>'databody'},ObjectLink(shift @r))
	   );
    foreach (@r) {
      print TR(
	       th({-class=>'datatitle'},'&nbsp;'),
	       td({-class=>'databody'},ObjectLink($_))
	      );
    }
  }
  print end_table;
}

sub print_qtl_information {
  my $obj = shift;

  print h2('QTL information');

  print start_table({-border=>1});

  if (my $a = $obj->Trait) {
    print TR(
	   th({-class=>'datatitle'},'Trait'),
	   td({-class=>'databody'},ObjectLink($a))
	   );
  }
  if (my @a = $obj->Map) {
    my $second = 0;
    print start_TR;
    for my $map (@a) {
      print $second++ ? th({-class=>'datatitle'},'&nbsp;')
                      : th({-class=>'datatitle'},'Region(s) Spanned');
      my $left  = $map->at('Ends.Left',1);
      my $right = $map->at('Ends.Right',1);
      print td({-class=>'databody'},'Chromosome',ObjectLink($map),"$left-$right cM");
      print end_TR;
    }
  }

  if (my $a = $obj->Interval_analysis_threshold) {
    print TR(
	   th({-class=>'datatitle'},'Significance Threshold'),
	   td({-class=>'databody'},$a)
	   );
  }

  if (my $a = $obj->Interval_analysis_value) {
    print TR(
	   th({-class=>'datatitle'},'Analysis Value'),
	   td({-class=>'databody'},$a)
	   );
  }

  if (my $a = $obj->Interval_analysis_r2) {
    print TR(
	   th({-class=>'datatitle'},'Interval Analysis R2'),
	   td({-class=>'databody'},$a)
	   );
  }


  if (my $a = $obj->Interval_analysis_allele_effect) {
    print TR(
	   th({-class=>'datatitle'},'Allele Effect'),
	   td({-class=>'databody'},$a)
	   );
  }

  if (my $a = $obj->Anova_F) {
    print TR(
	   th({-class=>'datatitle'},'ANOVA Value'),
	   td({-class=>'databody'},$a)
	   );
  }

  if (my $a = $obj->Anova_threshold) {
    print TR(
	   th({-class=>'datatitle'},'ANOVA Threshold'),
	   td({-class=>'databody'},$a)
	   );
  }

  if (my @a = $obj->Contains) {
    print TR(
	     th({-class=>'datatitle'},'Contained loci'),
	     td({-class=>'databody'},ObjectLink(shift @a))
	    );
    foreach (@a) {
      print TR(
	       th({-class=>'datatitle'},'&nbsp;'),
	       td({-class=>'databody'},ObjectLink($_))
	      );
    }
  }
  if (my @a = $obj->Significant_loci) {
    my $first = shift @a;
    print TR(
	     th({-class=>'datatitle'},'Significant loci'),
	     td({-class=>'databody'},ObjectLink("$first",'','Locus'))
	    );
    foreach (@a) {
      print TR(
	       th({-class=>'datatitle'},'&nbsp;'),
	       td({-class=>'databody'},ObjectLink($_))
	      );
    }
  }

  print end_table;

  my $remark = $obj->Remark;
  if ( $remark ) {
    print p(b('Remark: '),$remark);
  }

  my $info = $obj->Help->Info;
  if ( $info ) {
    print br,br;
    if ( Toggle('help','Help on QTL') ) {
      print pre($info->right);
    }
  }
}


