cgi-bin/phenome/qtl.pl

   1 #!/usr/bin/perl -w
   2
   3 =head1 DESCRIPTION
   4 A QTL detail page.
   5
   6 =head1 AUTHOR
   7
   8 Isaak Y Tecle (iyt2@cornell.edu)
   9
  10 =cut
  11
  12 use strict;
  13
  14 use CXGN::Page;
  15 use CXGN::Page::FormattingHelpers qw /info_section_html
  16   page_title_html
  17   columnar_table_html
  18   html_optional_show
  19   info_table_html
  20   tooltipped_text
  21   html_alternate_show
  22   /;
  23
  24 use CXGN::People::PageComment;
  25 use CXGN::Phenome::Population;
  26 use CXGN::Phenome::UserTrait;
  27 use CXGN::Phenome::Qtl;
  28 use CXGN::Marker;
  29 use CXGN::Map;
  30 use CXGN::DB::Connection;
  31 use CXGN::Chado::Cvterm;
  32 use List::MoreUtils qw /uniq/;
  33
  34 my $page = CXGN::Page->new( "qtl", "isaak" );
  35 my ( $pop_id, $trait_id, $lg, $l_m, $p_m, $r_m, $lod, $qtl_image ) =
  36   $page->get_encoded_arguments(
  37                                 "population_id", "term_id",
  38                                 "chr",           "l_marker",
  39                                 "p_marker",      "r_marker",
  40                                 "lod",            "qtl"
  41                               );
  42 my $dbh          = CXGN::DB::Connection->new();
  43 my $pop          = CXGN::Phenome::Population->new( $dbh, $pop_id );
  44 my $pop_name     = $pop->get_name();
  45 my $trait_name   = &trait_name( $pop, $trait_id );
  46 my $genetic_link = &genetic_map($pop);
  47 my $cmv_link     = &marker_positions( $pop, $lg, $l_m, $p_m, $r_m );
  48 my $gbrowse_link = &genome_positions( $l_m, $p_m, $r_m );
  49 my $marker_link  = &marker_detail( $l_m, $p_m, $r_m );
  50 my $legend       = &legend();
  51 my $comment      = &comment();
  52
  53 $c->forward_to_mason_view('/qtl/qtl.mas', qtl_image=>$qtl_image, pop_name=>$pop_name, trait_name=>$trait_name, cmv_link=>$cmv_link, gbrowse_link=>$gbrowse_link, marker_link=>$marker_link, genetic_map=>$genetic_link, legend=>$legend, comment=>$comment);
  54
  55
  56 sub marker_positions
  57 {
  58     my ( $pop, $lg, $l_m, $p_m, $r_m ) = @_;
  59     my $mapv_id = $pop->mapversion_id();
  60     my $l_m_pos = $pop->get_marker_position( $mapv_id, $l_m );
  61     my $p_m_pos = $pop->get_marker_position( $mapv_id, $p_m );
  62     my $r_m_pos = $pop->get_marker_position( $mapv_id, $r_m );
  63
  64     my $fl_markers =
  65 qq |<a href="../cview/view_chromosome.pl?map_version_id=$mapv_id&chr_nr=$lg&show_ruler=1&show_IL=&show_offsets=1&comp_map_version_id=&comp_chr=&color_model=&show_physical=&size=&show_zoomed=1&confidence=-2&hilite=$l_m+$p_m+$r_m&marker_type=&cM_start=$l_m_pos&cM_end=$r_m_pos">Chromosome $lg ($l_m, $r_m)</a> |;
  66
  67     return $fl_markers;
  68 }
  69
  70 sub genome_positions
  71 {
  72     my ( $l_m, $p_m, $r_m ) = uniq @_;
  73     my $genome_pos =
  74       qq |<a href="/gbrowse/bin/gbrowse/ITAG1_genomic/?name=$l_m">$l_m</a>|;
  75     $genome_pos .=
  76 qq |<br/><a href="/gbrowse/bin/gbrowse/ITAG1_genomic/?name=$p_m">$p_m</a>|;
  77     if ($r_m)
  78     {
  79         $genome_pos .=
  80 qq |<br/><a href="/gbrowse/bin/gbrowse/ITAG1_genomic/?name=$r_m">$r_m</a>|;
  81     }
  82     return $genome_pos;
  83 }
  84
  85 #move this to the population object
  86 sub genetic_map
  87 {
  88     my $pop      = shift;
  89     my $mapv_id  = $pop->mapversion_id();
  90     my $map      = CXGN::Map->new( $dbh, { map_version_id => $mapv_id } );
  91     my $map_name = $map->get_long_name();
  92     my $genetic_map =
  93       qq | <a href=/cview/map.pl?map_version_id=$mapv_id&hilite=$l_m+$p_m+$r_m>$map_name</a>|;
  94
  95     return $genetic_map;
  96
  97 }
  98
  99 sub marker_detail
 100 {
 101     my @markers = @_;
 102     my ( $m_link, $desc );
 103     for ( my $i = 0 ; $i < @markers ; $i++ )
 104     {
 105         my $marker = CXGN::Marker->new_with_name( $dbh, $markers[$i] );
 106         my $m_id = $marker->marker_id() unless !$marker;
 107         if ( $i == 0 ) { $desc = "Left flanking marker:"; }
 108         if ( $i == 1 ) { $desc = "Peak (<i>or the closest</i>) marker:"; }
 109         if ( $i == 2 ) { $desc = "Right flanking marker:"; }
 110         $m_link .=
 111 qq |<br/>$desc <a href="/search/markers/markerinfo.pl?marker_id=$m_id">$markers[$i]</a>|
 112           unless !$marker;
 113     }
 114
 115     return $m_link;
 116 }
 117
 118 sub trait_name
 119 {
 120     my ( $pop, $trait_id ) = @_;
 121
 122     my ( $term_obj, $term_name, $term_id );
 123     if ( $pop->get_web_uploaded() )
 124     {
 125         $term_obj  = CXGN::Phenome::UserTrait->new( $dbh, $trait_id );
 126         $term_name = $term_obj->get_name();
 127         $term_id   = $term_obj->get_user_trait_id();
 128     }
 129     else
 130     {
 131         $term_obj  = CXGN::Chado::Cvterm->new( $dbh, $trait_id );
 132         $term_name = $term_obj->get_cvterm_name();
 133         $term_id   = $term_obj->get_cvterm_id();
 134     }
 135
 136     return $term_name;
 137 }
 138
 139
 140 sub legend {
 141
 142    my $sp_person_id   = $pop->get_sp_person_id();
 143    my $qtl            = CXGN::Phenome::Qtl->new($sp_person_id);
 144    my $user_stat_file = $qtl->get_stat_file($c, $pop_id);
 145    my @stat;
 146    my $ci;
 147
 148     open $_, "<", $user_stat_file or die "$! reading $user_stat_file\n";
 149     while (my $row = <$_>)
 150     {
 151         my ( $parameter, $value ) = split( /\t/, $row );
 152
 153         if ($parameter =~/qtl_method/) {$parameter = 'Mapping method';}
 154         if ($parameter =~/qtl_model/) {$parameter = 'Mapping model';}
 155         if ($parameter =~/prob_method/) {$parameter = 'QTL genotype probability method';}
 156         if ($parameter =~/step_size/) {$parameter = 'Genome scan size (cM)';}
 157         if ($parameter =~/permu_level/) {$parameter = 'Permutation significance level';}
 158         if ($parameter =~/permu_test/) {$parameter = 'No. of permutations';}
 159         if ($parameter =~/prob_level/) {$parameter = 'QTL genotype significance level';}
 160
 161         if ($value eq 'zero' || $value eq 'Marker Regression') {$ci = 'none';}
 162
 163         unless (($parameter=~/no_draws/ && $value ==' ') ||
 164                ($parameter =~/QTL genotype probability/ && $value==' ')
 165                )
 166
 167         {
 168             push @stat, [map{$_} ($parameter, $value)];
 169         }
 170     }
 171
 172
 173     foreach my $st (@stat) {
 174         foreach my $i (@$st) {
 175             if ($i =~/zero/)  {
 176                 foreach my $s (@stat) {
 177                     foreach my $j (@$s) {
 178                         $j =~ s/Maximum Likelihood/Marker Regression/;
 179                         $ci = 'none';
 180                     }
 181                 }
 182             }
 183         }
 184     }
 185
 186
 187     if  (!$lod)
 188     {
 189         $lod = qq |<i>Not calculated</i>|;
 190     }
 191
 192     push @stat,
 193     [
 194      map {$_} ('LOD threshold', $lod)
 195     ];
 196
 197    unless ($ci) {
 198        push @stat,
 199        [
 200         map {$_} ('Confidence interval', 'Based on 95% Bayesian Credible Interval')
 201        ];
 202    }
 203
 204      return \@stat;
 205
 206 }
 207
 208 sub comment {
 209     my $comment;
 210     if ($pop_id) {
 211         my $page_comment_obj = CXGN::People::PageComment->new($dbh, "population", $pop_id, "/phenome/qtl.pl?population_id=$pop_id");
 212         $comment = $page_comment_obj->get_html();
 213     }
 214     return $comment;
 215
 216 }
 217