lib/SGN/Controller/Qtl.pm

   1 =head1 NAME
   2
   3 SGN::Controller::Qtl- controller for solQTL
   4
   5 =cut
   6
   7 package SGN::Controller::Qtl;
   8
   9 use Moose;
  10 use namespace::autoclean;
  11 use File::Spec::Functions;
  12 use List::MoreUtils qw /uniq/;
  13 use File::Temp qw / tempfile /;
  14 use File::Path qw / mkpath  /;
  15 use File::Copy;
  16 use File::Basename;
  17 use File::Slurp;
  18 use Try::Tiny;
  19 use URI::FromHash 'uri';
  20 use Cache::File;
  21 use Path::Class;
  22 use Bio::Chado::Schema;
  23 use CXGN::Phenome::Qtl;
  24 use CXGN::Phenome::Population;
  25
  26 BEGIN { extends 'Catalyst::Controller'}
  27
  28 sub view : Path('/qtl/view') Args(1) {
  29     my ($self, $c, $id) = @_;
  30     $c->res->redirect("/qtl/population/$id");
  31
  32 }
  33
  34
  35 sub population : Path('/qtl/population') Args(1) {
  36     my ( $self, $c, $id) = @_;
  37
  38     if ( $id )
  39     {
  40         $self->is_qtl_pop($c, $id);
  41         if ( $c->stash->{is_qtl_pop} )
  42         {
  43
  44             my $pop =  CXGN::Phenome::Population->new($c->dbc->dbh, $id);
  45             my $phenotype_file = $pop->phenotype_file($c);
  46             my $genotype_file =  $pop->genotype_file($c);
  47
  48             my $userid = $c->user->get_object->get_sp_person_id if $c->user;
  49             $c->stash(template     => '/qtl/population/index.mas',
  50                       pop          => $pop,
  51                       referer      => $c->req->path,
  52                       userid       => $userid,
  53                 );
  54             my $size = -s $phenotype_file;
  55
  56             $self->_link($c);
  57             $self->_show_data($c);
  58             $self->_list_traits($c);
  59             $self->genetic_map($c);
  60
  61             $self->_get_trait_acronyms($c);
  62
  63             }
  64             else
  65             {
  66                 $c->throw_404("$id is not a QTL population.");
  67             }
  68     }
  69     else
  70     {
  71             $c->throw_404("There is no QTL population for $id");
  72     }
  73
  74 }
  75
  76 sub download_phenotype : Path('/qtl/download/phenotype') Args(1) {
  77     my ($self, $c, $id) = @_;
  78
  79     $c->throw_404("<strong>$id</strong> is not a valid population id") if  $id =~ m/\D/;
  80
  81     $self->is_qtl_pop($c, $id);
  82     if ($c->stash->{is_qtl_pop})
  83     {
  84         my $pop             = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
  85         my $phenotype_file  = $pop->phenotype_file($c);
  86
  87         unless (!-e $phenotype_file || -s $phenotype_file <= 1)
  88         {
  89             my @pheno_data = map {   s/,/\t/g; [ $_ ]; } read_file($phenotype_file);
  90
  91             $c->res->content_type("text/plain");
  92             $c->res->body(join "",  map{ $_->[0]} @pheno_data);
  93         }
  94     }
  95     else
  96     {
  97         $c->throw_404("<strong>$id</strong> is not a QTL population id");
  98     }
  99 }
 100
 101 sub download_genotype : Path('/qtl/download/genotype') Args(1) {
 102     my ($self, $c, $id) = @_;
 103
 104     $c->throw_404("<strong>$id</strong> is not a valid population id") if  $id =~ m/\D/;
 105
 106     $self->is_qtl_pop($c, $id);
 107     if ($c->stash->{is_qtl_pop})
 108     {
 109
 110         my $pop             = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
 111         my $genotype_file   = $pop->genotype_file($c);
 112
 113         unless (!-e $genotype_file || -s $genotype_file <= 1)
 114         {
 115             my @geno_data = map { s/,/\t/g; [ $_ ]; } read_file($genotype_file);
 116
 117             $c->res->content_type("text/plain");
 118             $c->res->body(join "",  map{ $_->[0]} @geno_data);
 119         }
 120     }
 121     else
 122     {
 123         $c->throw_404("<strong>$id</strong> is not a QTL population id");
 124     }
 125 }
 126
 127 sub download_correlation : Path('/qtl/download/correlation') Args(1) {
 128     my ($self, $c, $id) = @_;
 129
 130     $c->throw_404("<strong>$id</strong> is not a valid population id") if $id =~ m/\D/;
 131
 132     $self->is_qtl_pop($c, $id);
 133     if ($c->stash->{is_qtl_pop})
 134     {
 135
 136         my $corr_file = catfile($c->path_to($c->config->{cluster_shared_tempdir}), 'correlation', 'cache',  "corre_coefficients_table_${id}");
 137
 138         unless (!-e $corr_file || -s $corr_file <= 1)
 139         {
 140             my @corr_data;
 141             my $count=1;
 142
 143             foreach ( read_file($corr_file) )
 144             {
 145                 if ($count==1) {  $_ = "Traits\t" . $_;}
 146                 s/NA//g;
 147                 push @corr_data, [ $_ ] ;
 148                 $count++;
 149             }
 150             $c->res->content_type("text/plain");
 151             $c->res->body(join "",  map{ $_->[0] } @corr_data);
 152
 153         }
 154     }
 155     else
 156     {
 157         $c->throw_404("<strong>$id</strong> is not a QTL population id");
 158     }
 159 }
 160
 161 sub download_acronym : Path('/qtl/download/acronym') Args(1) {
 162     my ($self, $c, $id) = @_;
 163
 164     $c->throw_404("<strong>$id</strong> is not a valid population id") if  $id =~ m/\D/;
 165
 166     $self->is_qtl_pop($c, $id);
 167     if ($c->stash->{is_qtl_pop})
 168     {
 169         my $pop = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
 170         my $acronym = $pop->get_cvterm_acronyms;
 171
 172         $c->res->content_type("text/plain");
 173         $c->res->body(join "\n",  map{ $_->[1] . "\t" . $_->[0] } @$acronym);
 174
 175     }
 176     else
 177     {
 178         $c->throw_404("<strong>$id</strong> is not a QTL population id");
 179     }
 180 }
 181
 182
 183 sub _analyze_correlation  {
 184     my ($self, $c)      = @_;
 185     my $pop_id          = $c->stash->{pop}->get_population_id();
 186     my $pheno_file      = $c->stash->{pop}->phenotype_file($c);
 187     my $base_path       = $c->config->{basepath};
 188     my $temp_image_dir  = $c->config->{tempfiles_subdir};
 189     my $r_qtl_dir       = $c->config->{solqtl};
 190     my $corre_image_dir = catfile($base_path, $temp_image_dir, "correlation");
 191     my $corre_temp_dir  = catfile($r_qtl_dir, "cache");
 192
 193     if (-s $pheno_file)
 194     {
 195         mkpath ([$corre_temp_dir, $corre_image_dir], 0, 0755);
 196
 197         my ($fh_hm, $heatmap_file)     = tempfile( "heatmap_${pop_id}-XXXXXX",
 198                                                   DIR      => $corre_temp_dir,
 199                                                   SUFFIX   => '.png',
 200                                                   UNLINK   => 0,
 201                                                 );
 202         $fh_hm->close;
 203
 204         print STDERR "\nheatmap tempfile: $heatmap_file\n";
 205
 206         my ($fh_ct, $corre_table_file) = tempfile( "corre_table_${pop_id}-XXXXXX",
 207                                                   DIR      => $corre_temp_dir,
 208                                                   SUFFIX   => '.txt',
 209                                                   UNLINK   => 0,
 210                                                 );
 211         $fh_ct->close;
 212
 213         print STDERR "\ncorrelation coefficients tempfile: $corre_table_file\n";
 214
 215         CXGN::Tools::Run->temp_base($corre_temp_dir);
 216         my ($fh_out, $filename);
 217         my ( $corre_commands_temp, $corre_output_temp ) =
 218             map
 219         {
 220             ($fh_out, $filename ) =
 221                 tempfile(
 222                     File::Spec->catfile(
 223                         CXGN::Tools::Run->temp_base(),
 224                         "corre_pop_${pop_id}-$_-XXXXXX",
 225                          ),
 226                     UNLINK   => 0,
 227                 );
 228             $filename
 229         } qw / in out /;
 230
 231         $fh_out->close;
 232         print STDERR "\ncorrelation r output  tempfile: $corre_output_temp\n";
 233
 234         {
 235             my $corre_commands_file = $c->path_to('/cgi-bin/phenome/correlation.r');
 236             copy( $corre_commands_file, $corre_commands_temp )
 237                 or die "could not copy '$corre_commands_file' to '$corre_commands_temp'";
 238         }
 239         try
 240         {
 241             print STDERR "\nsubmitting correlation job to the cluster..\n";
 242             my $r_process = CXGN::Tools::Run->run_cluster(
 243                 'R', 'CMD', 'BATCH',
 244                 '--slave',
 245                 "--args $heatmap_file $corre_table_file $pheno_file",
 246                 $corre_commands_temp,
 247                 $corre_output_temp,
 248                 {
 249                     working_dir => $corre_temp_dir,
 250                     max_cluster_jobs => 1_000_000_000,
 251                 },
 252                 );
 253
 254             $r_process->wait;
 255             sleep 5;
 256             print STDERR "\ndone with correlation analysis..\n";
 257        }
 258         catch
 259         {
 260             print STDERR "\nsubmitting correlation job to the cluster gone wrong....\n";
 261             my $err = $_;
 262             $err =~ s/\n at .+//s; #< remove any additional backtrace
 263             #     # try to append the R output
 264             try{ $err .= "\n=== R output ===\n".file($corre_output_temp)->slurp."\n=== end R output ===\n" };
 265             # die with a backtrace
 266             Carp::confess $err;
 267         };
 268
 269         copy($heatmap_file, $corre_image_dir)
 270             or die "could not copy $heatmap_file to $corre_image_dir";
 271         copy($corre_table_file, $corre_image_dir)
 272             or die "could not copy $corre_table_file to $corre_image_dir";
 273
 274         $heatmap_file      = fileparse($heatmap_file);
 275         $heatmap_file      = $c->generated_file_uri("correlation",  $heatmap_file);
 276         $corre_table_file  = fileparse($corre_table_file);
 277         $corre_table_file  = $c->generated_file_uri("correlation", $corre_table_file);
 278
 279         print STDERR "\nheatmap tempfile after copying to the apps static dir : $heatmap_file\n";
 280         print STDERR "\ncorrelation coefficients after copying to the apps static dir: $corre_table_file\n";
 281
 282         $c->stash( heatmap_file     => $heatmap_file,
 283                    corre_table_file => $corre_table_file
 284                  );
 285     }
 286 }
 287
 288 sub _correlation_output {
 289     my ($self, $c)      = @_;
 290     my $pop             = $c->{stash}->{pop};
 291     my $base_path       = $c->config->{basepath};
 292     my $temp_image_dir  = $c->config->{tempfiles_subdir};
 293     my $corre_image_dir = catfile($base_path, $temp_image_dir, "correlation");
 294     my $cache           = Cache::File->new( cache_root  => $corre_image_dir);
 295     $cache->purge();
 296
 297     my $key_h           = "heat_" . $pop->get_population_id();
 298     my $key_t           = "corr_table_" . $pop->get_population_id();
 299     my $heatmap         = $cache->get($key_h);
 300     my $corre_table     = $cache->get($key_t);
 301
 302      print STDERR "\ncached heatmap file: $heatmap\n";
 303      print STDERR "\ncached correlation coefficients files: $corre_table\n";
 304
 305     unless ($heatmap)
 306     {
 307         $self->_analyze_correlation($c);
 308
 309         $heatmap = $c->stash->{heatmap_file};
 310         $corre_table  = $c->stash->{corre_table_file};
 311
 312         $cache->set($key_h, $heatmap, "30 days");
 313         $cache->set($key_t, $corre_table, "30 days");
 314     }
 315
 316     $heatmap     = undef if -z $c->config->{basepath} . $heatmap;
 317     $corre_table = undef if -z $c->config->{basepath} . $corre_table;
 318
 319     $c->stash( heatmap_file     => $heatmap,
 320                corre_table_file => $corre_table,
 321              );
 322
 323     $self->_get_trait_acronyms($c);
 324
 325 }
 326
 327 sub _list_traits {
 328     my ($self, $c) = @_;
 329     my $population_id = $c->stash->{pop}->get_population_id();
 330     my @phenotype;
 331
 332     if ($c->stash->{pop}->get_web_uploaded())
 333     {
 334         my @traits = $c->stash->{pop}->get_cvterms();
 335
 336         foreach my $trait (@traits)
 337         {
 338             my $trait_id   = $trait->get_user_trait_id();
 339             my $trait_name = $trait->get_name();
 340             my $definition = $trait->get_definition();
 341
 342             my ($min, $max, $avg, $std, $count) = $c->stash->{pop}->get_pop_data_summary($trait_id);
 343
 344             $c->stash( trait_id   => $trait_id,
 345                        trait_name => $trait_name
 346                 );
 347
 348             $self->_link($c);
 349             my $trait_link = $c->stash->{trait_page};
 350
 351             my $qtl_analysis_page = $c->stash->{qtl_analysis_page};
 352             push  @phenotype,  [ map { $_ } ( $trait_link, $min, $max, $avg, $count, $qtl_analysis_page ) ];
 353         }
 354     }
 355     else
 356     {
 357         my @cvterms = $c->stash->{pop}->get_cvterms();
 358         foreach my $cvterm( @cvterms )
 359         {
 360             my $cvterm_id = $cvterm->get_cvterm_id();
 361             my $cvterm_name = $cvterm->get_cvterm_name();
 362             my ($min, $max, $avg, $std, $count)= $c->stash->{pop}->get_pop_data_summary($cvterm_id);
 363
 364             $c->stash( trait_name => $cvterm_name,
 365                        cvterm_id  => $cvterm_id
 366                 );
 367
 368             $self->_link($c);
 369             my $qtl_analysis_page = $c->stash->{qtl_analysis_page};
 370             my $cvterm_page = $c->stash->{cvterm_page};
 371             push  @phenotype,  [ map { $_ } ( $cvterm_page, $min, $max, $avg, $count, $qtl_analysis_page ) ];
 372         }
 373     }
 374     $c->stash->{traits_list} = \@phenotype;
 375 }
 376
 377 #given $c and a population id, checks if it is a qtl population and stashes true or false
 378 sub is_qtl_pop {
 379     my ($self, $c, $id) = @_;
 380     my $qtltool = CXGN::Phenome::Qtl::Tools->new();
 381     my @qtl_pops = $qtltool->has_qtl_data();
 382
 383     foreach my $qtl_pop ( @qtl_pops )
 384     {
 385         my $pop_id = $qtl_pop->get_population_id();
 386         $pop_id == $id ? $c->stash(is_qtl_pop => 1) && last
 387                        : $c->stash(is_qtl_pop => 0)
 388                        ;
 389     }
 390 }
 391
 392
 393 sub _link {
 394     my ($self, $c) = @_;
 395     my $pop_id     = $c->stash->{pop}->get_population_id();
 396
 397     {
 398         no warnings 'uninitialized';
 399         my $trait_id   = $c->stash->{trait_id};
 400         my $cvterm_id  = $c->stash->{cvterm_id};
 401         my $trait_name = $c->stash->{trait_name};
 402         my $term_id    = $trait_id ? $trait_id : $cvterm_id;
 403         my $graph_icon = qq | <img src="/documents/img/pop_graph.png" alt="run solqtl"/> |;
 404
 405         $self->_get_owner_details($c);
 406         my $owner_name = $c->stash->{owner_name};
 407         my $owner_id   = $c->stash->{owner_id};
 408
 409         $c->stash( cvterm_page        => qq |<a href="/cvterm/$cvterm_id/view">$trait_name</a> |,
 410                    trait_page         => qq |<a href="/phenome/trait.pl?trait_id=$trait_id">$trait_name</a> |,
 411                    owner_page         => qq |<a href="/solpeople/personal-info.pl?sp_person_id=$owner_id">$owner_name</a> |,
 412                    guideline          => qq |<a href="/qtl/submission/guide">Guideline</a> |,
 413                    phenotype_download => qq |<a href="/qtl/download/phenotype/$pop_id">Phenotype data</a> |,
 414                    genotype_download  => qq |<a href="/qtl/download/genotype/$pop_id">Genotype data</a> |,
 415                    corre_download     => qq |<a href="/download/phenotypic/correlation/population/$pop_id">Correlation data</a> |,
 416                    acronym_download   => qq |<a href="/qtl/download/acronym/$pop_id">Trait-acronym key</a> |,
 417                    qtl_analysis_page  => qq |<a href="/phenome/qtl_analysis.pl?population_id=$pop_id&amp;cvterm_id=$term_id" onclick="Qtl.waitPage()">$graph_icon</a> |,
 418             );
 419     }
 420
 421 }
 422
 423 sub _get_trait_acronyms {
 424     my ($self, $c) = @_;
 425
 426     $c->stash(trait_acronym_pairs => $c->stash->{pop}->get_cvterm_acronyms());
 427
 428 }
 429
 430 sub _get_owner_details {
 431     my ($self, $c) = @_;
 432     my $owner_id   = $c->stash->{pop}->get_sp_person_id();
 433     my $owner      = CXGN::People::Person->new($c->dbc->dbh, $owner_id);
 434     my $owner_name = $owner->get_first_name()." ".$owner->get_last_name();
 435
 436     $c->stash( owner_name => $owner_name,
 437                owner_id   => $owner_id
 438         );
 439
 440 }
 441
 442 sub _show_data {
 443     my ($self, $c) = @_;
 444     my $user_id    = $c->stash->{userid};
 445     my $user_type  = $c->user->get_object->get_user_type() if $c->user;
 446     my $is_public  = $c->stash->{pop}->get_privacy_status();
 447     my $owner_id   = $c->stash->{pop}->get_sp_person_id();
 448
 449     if ($user_id)
 450     {
 451         ($user_id == $owner_id || $user_type eq 'curator') ? $c->stash(show_data => 1)
 452                   :                                          $c->stash(show_data => undef)
 453                   ;
 454     } else
 455     {
 456         $is_public ? $c->stash(show_data => 1)
 457                    : $c->stash(show_data => undef)
 458                    ;
 459     }
 460 }
 461
 462 sub set_stat_option : PathPart('qtl/stat/option') Chained Args(0) {
 463     my ($self, $c)  = @_;
 464     my $pop_id      = $c->req->param('pop_id');
 465     my $stat_params = $c->req->param('stat_params');
 466     my $file        = $self->stat_options_file($c, $pop_id);
 467
 468     if ($file)
 469     {
 470         my $f = file( $file )->openw
 471             or die "Can't create file: $! \n";
 472
 473         if ( $stat_params eq 'default' )
 474         {
 475             $f->print( "default parameters\tYes" );
 476         }
 477         else
 478         {
 479             $f->print( "default parameters\tNo" );
 480         }
 481     }
 482     $c->res->content_type('application/json');
 483     $c->res->body({undef});
 484
 485 }
 486
 487 sub stat_options_file {
 488     my ($self, $c, $pop_id) = @_;
 489     my $login_id            = $c->user()->get_object->get_sp_person_id() if $c->user;
 490
 491     if ($login_id)
 492     {
 493         my $qtl = CXGN::Phenome::Qtl->new($login_id);
 494         my ($temp_qtl_dir, $temp_user_dir) = $qtl->create_user_qtl_dir($c);
 495         return  catfile( $temp_user_dir, "stat_options_pop_${pop_id}.txt" );
 496     }
 497     else
 498     {
 499         return;
 500     }
 501 }
 502
 503
 504 sub qtl_form : PathPart('qtl/form') Chained Args {
 505     my ($self, $c, $type, $pop_id) = @_;
 506
 507     my $userid = $c->user()->get_object->get_sp_person_id() if $c->user;
 508
 509     unless ($userid)
 510     {
 511        $c->res->redirect( '/user/login' );
 512     }
 513
 514     $type = 'intro' if !$type;
 515
 516     if (!$pop_id and $type !~ /intro|pop_form/ )
 517     {
 518      $c->throw_404("Population id argument is missing");
 519     }
 520
 521     if ($pop_id and $pop_id !~ /^([0-9]+)$/)
 522     {
 523         $c->throw_404("<strong>$pop_id</strong> is not an accepted argument.
 524                         This form expects an all digit population id, instead of
 525                         <strong>$pop_id</strong>"
 526                      );
 527     }
 528
 529     $c->stash( template => $self->get_template($c, $type),
 530                pop_id   => $pop_id,
 531                guide    => qq |<a href="/qtl/submission/guide">Guideline</a> |,
 532                referer  => $c->req->path,
 533                userid   => $userid
 534             );
 535
 536 }
 537
 538 sub templates {
 539     my $self = shift;
 540     my %template_of = ( intro      => '/qtl/qtl_form/intro.mas',
 541                         pop_form   => '/qtl/qtl_form/pop_form.mas',
 542                         pheno_form => '/qtl/qtl_form/pheno_form.mas',
 543                         geno_form  => '/qtl/qtl_form/geno_form.mas',
 544                         trait_form => '/qtl/qtl_form/trait_form.mas',
 545                         stat_form  => '/qtl/qtl_form/stat_form.mas',
 546                         confirm    => '/qtl/qtl_form/confirm.mas'
 547                       );
 548         return \%template_of;
 549 }
 550
 551
 552 sub get_template {
 553     my ($self, $c, $type) = @_;
 554     return $self->templates->{$type};
 555 }
 556
 557 sub submission_guide : PathPart('qtl/submission/guide') Chained Args(0) {
 558     my ($self, $c) = @_;
 559     $c->stash(template => '/qtl/submission/guide/index.mas');
 560 }
 561
 562 sub genetic_map {
 563     my ($self, $c)  = @_;
 564     my $mapv_id     = $c->stash->{pop}->mapversion_id();
 565     my $map         = CXGN::Map->new( $c->dbc->dbh, { map_version_id => $mapv_id } );
 566     my $map_name    = $map->get_long_name();
 567     my $map_sh_name = $map->get_short_name();
 568
 569     $c->stash( genetic_map => qq | <a href=/cview/map.pl?map_version_id=$mapv_id>$map_name ($map_sh_name)</a> | );
 570
 571 }
 572
 573 sub search_help : PathPart('qtl/search/help') Chained Args(0) {
 574     my ($self, $c) = @_;
 575     $c->stash(template => '/qtl/search/help/index.mas');
 576 }
 577
 578 sub show_search_results : PathPart('qtl/search/results') Chained Args(0) {
 579     my ($self, $c) = @_;
 580     my $trait = $c->req->param('trait');
 581     $trait =~ s/(^\s+|\s+$)//g;
 582     $trait =~ s/\s+/ /g;
 583
 584     my $rs = $self->search_qtl_traits($c, $trait);
 585
 586     if ($rs)
 587     {
 588         my $rows = $self->mark_qtl_traits($c, $rs);
 589
 590         $c->stash(template   => '/qtl/search/results.mas',
 591                   data       => $rows,
 592                   query      => $c->req->param('trait'),
 593                   pager      => $rs->pager,
 594                   page_links => sub {uri ( query => { trait => $c->req->param('trait'), page => shift } ) }
 595             );
 596     }
 597     else
 598     {
 599         $c->stash(template   => '/qtl/search/results.mas',
 600                   data       => undef,
 601                   query      => undef,
 602                   pager      => undef,
 603                   page_links => undef,
 604             );
 605     }
 606 }
 607
 608 sub search_qtl_traits {
 609     my ($self, $c, $trait) = @_;
 610
 611     my $rs;
 612     if ($trait)
 613     {
 614         my $sp_person_id = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
 615         my $schema    = $c->dbic_schema("Bio::Chado::Schema", undef, $sp_person_id);
 616         my $cv_id     = $schema->resultset("Cv::Cv")->search(
 617             {name => 'solanaceae_phenotype'}
 618             )->single->cv_id;
 619
 620         $rs = $schema->resultset("Cv::Cvterm")->search(
 621             { name  => { 'LIKE' => '%'.$trait .'%'},
 622               cv_id => $cv_id,
 623             },
 624             {
 625               columns => [ qw/ cvterm_id name definition / ]
 626             },
 627             {
 628               page     => $c->req->param('page') || 1,
 629               rows     => 10,
 630               order_by => 'name'
 631             }
 632             );
 633     }
 634     return $rs;
 635 }
 636
 637 sub mark_qtl_traits {
 638     my ($self, $c, $rs) = @_;
 639     my @rows =();
 640
 641     if (!$rs->single)
 642     {
 643         return undef;
 644     }
 645     else
 646     {
 647         my $qtltool  = CXGN::Phenome::Qtl::Tools->new();
 648         my $yes_mark = qq |<font size=4 color="#0033FF"> &#10003;</font> |;
 649         my $no_mark  = qq |<font size=4 color="#FF0000"> X </font> |;
 650
 651         while (my $cv = $rs->next)
 652         {
 653             my $id   = $cv->cvterm_id;
 654             my $name = $cv->name;
 655             my $def  = $cv->definition;
 656
 657             if (  $qtltool->is_from_qtl( $id ) )
 658             {
 659                 push @rows, [ qq | <a href="/cvterm/$id/view">$name</a> |, $def, $yes_mark ];
 660
 661             }
 662             else
 663             {
 664                 push @rows, [ qq | <a href="/cvterm/$id/view">$name</a> |, $def, $no_mark ];
 665             }
 666         }
 667         return \@rows;
 668     }
 669 }
 670
 671
 672 sub qtl_traits : PathPart('qtl/traits') Chained Args(1) {
 673     my ($self, $c, $index) = @_;
 674
 675     if ($index =~ /^\w{1}$/)
 676     {
 677         my $traits_list = $self->map_qtl_traits($c, $index);
 678
 679         $c->stash( template    => '/qtl/traits/index.mas',
 680                    index       => $index,
 681                    traits_list => $traits_list
 682             );
 683     }
 684     else
 685     {
 686         $c->res->redirect('/search/qtl');
 687     }
 688 }
 689
 690 sub all_qtl_traits : PathPart('qtl/traits') Chained Args(0) {
 691     my ($self, $c) = @_;
 692     $c->res->redirect('/search/qtl');
 693 }
 694
 695 sub filter_qtl_traits {
 696     my ($self, $index) = @_;
 697
 698     my $qtl_tools = CXGN::Phenome::Qtl::Tools->new();
 699     my ( $all_traits, $all_trait_d ) = $qtl_tools->all_traits_with_qtl_data();
 700
 701     return [
 702         sort { $a cmp $b  }
 703         grep { /^$index/i }
 704         uniq @$all_traits
 705     ];
 706 }
 707
 708 sub map_qtl_traits {
 709     my ($self, $c, $index) = @_;
 710
 711     my $traits_list = $self->filter_qtl_traits($index);
 712
 713     my @traits_urls;
 714     if (@{$traits_list})
 715     {
 716         foreach my $trait (@{$traits_list})
 717         {
 718             my $cvterm = CXGN::Chado::Cvterm::get_cvterm_by_name( $c->dbc->dbh, $trait );
 719             my $cvterm_id = $cvterm->get_cvterm_id();
 720             if ($cvterm_id)
 721             {
 722                 push @traits_urls,
 723                 [
 724                  map { $_ }
 725                  (
 726                   qq |<a href=/cvterm/$cvterm_id/view>$trait</a> |
 727                  )
 728                 ];
 729             }
 730             else
 731             {
 732                 my $t = CXGN::Phenome::UserTrait->new_with_name( $c->dbc->dbh, $trait );
 733                 my $trait_id = $t->get_user_trait_id();
 734                 push @traits_urls,
 735                 [
 736                  map { $_ }
 737                  (
 738                   qq |<a href=/phenome/trait.pl?trait_id=$trait_id>$trait</a> |
 739                  )
 740                 ];
 741             }
 742         }
 743     }
 744
 745     return \@traits_urls;
 746 }
 747
 748 __PACKAGE__->meta->make_immutable;
 749 ####
 750 1;
 751 ####