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::Phenome::Population;
  25 use CXGN::Phenome::UserTrait;
  26 use CXGN::Phenome::Qtl;
  27 use CXGN::Marker;
  28 use CXGN::Chado::Cvterm;
  29 use List::MoreUtils qw /uniq/;
  30
  31 my $page = CXGN::Page->new( "qtl", "isaak" );
  32 my ( $pop_id, $trait_id, $lg, $l_m, $p_m, $r_m, $lod, $qtl_image ) =
  33   $page->get_encoded_arguments(
  34                                 "population_id", "term_id",
  35                                 "chr",           "l_marker",
  36                                 "p_marker",      "r_marker",
  37                                 "lod",            "qtl"
  38                               );
  39 my $dbh          = CXGN::DB::Connection->new();
  40 my $pop          = CXGN::Phenome::Population->new( $dbh, $pop_id );
  41 my $pop_name     = $pop->get_name();
  42 my $trait_name   = &trait_name( $pop, $trait_id );
  43 my $genetic_link = &genetic_map($pop);
  44 my $cmv_link     = &marker_positions( $pop, $lg, $l_m, $p_m, $r_m );
  45 my $gbrowse_link = &genome_positions( $l_m, $p_m, $r_m );
  46 my $marker_link  = &marker_detail( $l_m, $p_m, $r_m );
  47 my $legend       = &legend();
  48 my $comment      = &comment();
  49
  50 $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);
  51
  52
  53 sub marker_positions
  54 {
  55     my ( $pop, $lg, $l_m, $p_m, $r_m ) = @_;
  56     my $mapv_id = $pop->mapversion_id();
  57     my $l_m_pos = $pop->get_marker_position( $mapv_id, $l_m );
  58     my $p_m_pos = $pop->get_marker_position( $mapv_id, $p_m );
  59     my $r_m_pos = $pop->get_marker_position( $mapv_id, $r_m );
  60
  61     my $fl_markers =
  62 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> |;
  63
  64     return $fl_markers;
  65 }
  66
  67 sub genome_positions
  68 {
  69     my ( $l_m, $p_m, $r_m ) = uniq @_;
  70     my $genome_pos =
  71       qq |<a href="/gbrowse/bin/gbrowse/ITAG1_genomic/?name=$l_m">$l_m</a>|;
  72     $genome_pos .=
  73 qq |<br/><a href="/gbrowse/bin/gbrowse/ITAG1_genomic/?name=$p_m">$p_m</a>|;
  74     if ($r_m)
  75     {
  76         $genome_pos .=
  77 qq |<br/><a href="/gbrowse/bin/gbrowse/ITAG1_genomic/?name=$r_m">$r_m</a>|;
  78     }
  79     return $genome_pos;
  80 }
  81
  82 #move this to the population object
  83 sub genetic_map
  84 {
  85     my $pop      = shift;
  86     my $mapv_id  = $pop->mapversion_id();
  87     my $map      = CXGN::Map->new( $dbh, { map_version_id => $mapv_id } );
  88     my $map_name = $map->get_long_name();
  89     my $genetic_map =
  90       qq | <a href=/cview/map.pl?map_version_id=$mapv_id&hilite=$l_m+$p_m+$r_m>$map_name</a>|;
  91
  92     return $genetic_map;
  93
  94 }
  95
  96 sub marker_detail
  97 {
  98     my @markers = @_;
  99     my ( $m_link, $desc );
 100     for ( my $i = 0 ; $i < @markers ; $i++ )
 101     {
 102         my $marker = CXGN::Marker->new_with_name( $dbh, $markers[$i] );
 103         my $m_id = $marker->marker_id() unless !$marker;
 104         if ( $i == 0 ) { $desc = "Left flanking marker:"; }
 105         if ( $i == 1 ) { $desc = "Peak (<i>or the closest</i>) marker:"; }
 106         if ( $i == 2 ) { $desc = "Right flanking marker:"; }
 107         $m_link .=
 108 qq |<br/>$desc <a href="/search/markers/markerinfo.pl?marker_id=$m_id">$markers[$i]</a>|
 109           unless !$marker;
 110     }
 111
 112     return $m_link;
 113 }
 114
 115 sub trait_name
 116 {
 117     my ( $pop, $trait_id ) = @_;
 118
 119     my ( $term_obj, $term_name, $term_id );
 120     if ( $pop->get_web_uploaded() )
 121     {
 122         $term_obj  = CXGN::Phenome::UserTrait->new( $dbh, $trait_id );
 123         $term_name = $term_obj->get_name();
 124         $term_id   = $term_obj->get_user_trait_id();
 125     }
 126     else
 127     {
 128         $term_obj  = CXGN::Chado::Cvterm->new( $dbh, $trait_id );
 129         $term_name = $term_obj->get_cvterm_name();
 130         $term_id   = $term_obj->get_cvterm_id();
 131     }
 132
 133     return $term_name;
 134 }
 135
 136
 137 sub legend {
 138
 139    my $sp_person_id   = $pop->get_sp_person_id();
 140    my $qtl            = CXGN::Phenome::Qtl->new($sp_person_id);
 141     my $user_stat_file = $qtl->get_stat_file($c, $pop_id);
 142     my @stat;
 143
 144     open $_, "<", $user_stat_file or die "$! reading $user_stat_file\n";
 145     while (my $row = <$_>)
 146     {
 147         my ( $parameter, $value ) = split( /\t/, $row );
 148         if ($parameter =~/qtl_method/) {$parameter = 'Mapping method';}
 149         if ($parameter =~/qtl_model/) {$parameter = 'Mapping model';}
 150         if ($parameter =~/prob_method/) {$parameter = 'QTL genotype probablity method';}
 151         if ($parameter =~/step_size/) {$parameter = 'Genome scan size (cM)';}
 152         if ($parameter =~/permu_level/) {$parameter = 'Permutation significance level';}
 153         if ($parameter =~/permu_test/) {$parameter = 'No. of permutations';}
 154         if ($parameter =~/prob_level/) {$parameter = 'QTL genotype signifance level';}
 155
 156
 157         push @stat, [map{$_} ($parameter, $value)];
 158
 159     }
 160
 161     if  (!$lod)
 162     {
 163         $lod = qq |<i>Not calculated</i>|;
 164     }
 165
 166     push @stat,
 167     [
 168      map {$_} ('LOD threshold', $lod)
 169     ];
 170     push @stat,
 171     [
 172      map {$_} ('Confidence interval', 'Based on 95% Bayesian Credible Interval')
 173     ];
 174
 175
 176
 177      return \@stat;
 178
 179 }
 180
 181 sub comment {
 182     my $comment;
 183     if ($pop_id) {
 184         my $page_comment_obj = CXGN::People::PageComment->new($dbh, "population", $pop_id);
 185         $comment = $page_comment_obj->get_html();
 186     }
 187     return $comment;
 188
 189 }