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 File::Temp qw / tempfile /;
  13 use File::Path qw / mkpath  /;
  14 use File::Copy;
  15 use File::Basename;
  16 use File::Slurp;
  17 use Try::Tiny;
  18 use URI::FromHash 'uri';
  19 use Cache::File;
  20 use Path::Class;
  21 use Bio::Chado::Schema;
  22 use CXGN::Phenome::Qtl;
  23
  24 BEGIN { extends 'Catalyst::Controller'}
  25
  26 sub view : PathPart('qtl/view') Chained Args(1) {
  27     my ($self, $c, $id) = @_;
  28     $c->res->redirect("/qtl/population/$id");
  29 }
  30
  31
  32 sub population : PathPart('qtl/population') Chained Args(1) {
  33     my ( $self, $c, $id) = @_;
  34
  35     if ( $id !~ /^\d+$/ )
  36     {
  37         $c->throw_404("$id is not a valid population id.");
  38     }
  39     elsif ( $id )
  40     {
  41         my $schema = $c->dbic_schema('CXGN::Phenome::Schema');
  42         my $rs = $schema->resultset('Population')->find($id);
  43         if ($rs)
  44         {
  45             $self->_is_qtl_pop($c, $id);
  46             if ( $c->stash->{is_qtl_pop} )
  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          => CXGN::Phenome::Population->new($c->dbc->dbh, $id),
  51                           referer      => $c->req->path,
  52                           userid       => $userid,
  53                     );
  54                 $self->_link($c);
  55                 $self->_show_data($c);
  56                 $self->_list_traits($c);
  57                 $self->genetic_map($c);
  58
  59                 if ( $id == 18 )
  60                 {
  61                     $c->stash(heatmap_file => undef,
  62                               corre_table_file => undef,
  63                         );
  64                     $self->_get_trait_acronyms($c);
  65
  66                 }
  67                 else
  68                 {
  69                     $self->_correlation_output($c);
  70                 }
  71             }
  72             else
  73             {
  74                 $c->throw_404("$id is not a QTL population.");
  75             }
  76         }
  77         else
  78         {
  79             $c->throw_404("There is no QTL population for $id");
  80         }
  81
  82     }
  83     elsif (!$id)
  84     {
  85         $c->throw_404("You must provide a valid population id argument");
  86     }
  87 }
  88
  89 sub download_phenotype : PathPart('qtl/download/phenotype') Chained Args(1) {
  90     my ($self, $c, $id) = @_;
  91     my $pop             = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
  92     my $phenotype_file  = $pop->phenotype_file($c);
  93
  94     unless (!-e $phenotype_file || -s $phenotype_file <= 1)
  95     {
  96         my @pheno_data;
  97         foreach ( read_file($phenotype_file) )
  98         {
  99             push @pheno_data, [ split(/,/) ];
 100         }
 101         $c->stash->{'csv'}={ data => \@pheno_data};
 102         $c->forward("SGN::View::Download::CSV");
 103     }
 104 }
 105
 106 sub download_genotype : PathPart('qtl/download/genotype') Chained Args(1) {
 107     my ($self, $c, $id) = @_;
 108     my $pop             = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
 109     my $genotype_file   = $pop->genotype_file($c);
 110
 111     unless (!-e $genotype_file || -s $genotype_file <= 1)
 112     {
 113         my @geno_data;
 114         foreach ( read_file($genotype_file))
 115         {
 116             push @geno_data, [ split(/,/) ];
 117         }
 118         $c->stash->{'csv'}={ data => \@geno_data};
 119         $c->forward("SGN::View::Download::CSV");
 120     }
 121 }
 122
 123 sub download_correlation : PathPart('qtl/download/correlation') Chained Args(1) {
 124     my ($self, $c, $id) = @_;
 125
 126     $c->stash(pop => CXGN::Phenome::Population->new($c->dbc->dbh, $id));
 127     $self->_correlation_output($c);
 128     my $corr_file = $c->stash->{corre_table_file};
 129     my $base_path = $c->config->{basepath};
 130     $corr_file    = $base_path . $corr_file;
 131
 132     unless (!-e $corr_file || -s $corr_file <= 1)
 133     {
 134         my @corr_data;
 135         my $count=1;
 136
 137         foreach ( read_file($corr_file) )
 138         {
 139             if ($count==1) { $_ = "Traits " . $_;}
 140             s/\s/,/g;
 141             push @corr_data, [ split (/,/) ];
 142             $count++;
 143         }
 144
 145         $c->stash->{'csv'}={ data => \@corr_data };
 146         $c->forward("SGN::View::Download::CSV");
 147     }
 148 }
 149
 150 sub download_acronym : PathPart('qtl/download/acronym') Chained Args(1) {
 151     my ($self, $c, $id) = @_;
 152     my $pop = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
 153     $c->stash->{'csv'}={ data => $pop->get_cvterm_acronyms};
 154     $c->forward("SGN::View::Download::CSV");
 155 }
 156
 157
 158 sub _analyze_correlation  {
 159     my ($self, $c)      = @_;
 160     my $pop_id          = $c->stash->{pop}->get_population_id();
 161     my $pheno_file      = $c->stash->{pop}->phenotype_file($c);
 162     my $base_path       = $c->config->{basepath};
 163     my $temp_image_dir  = $c->config->{tempfiles_subdir};
 164     my $r_qtl_dir       = $c->config->{r_qtl_temp_path};
 165     my $corre_image_dir = catfile($base_path, $temp_image_dir, "correlation");
 166     my $corre_temp_dir  = catfile($r_qtl_dir, "tempfiles");
 167
 168     if (-s $pheno_file)
 169     {
 170         foreach my $dir ($corre_temp_dir, $corre_image_dir)
 171         {
 172             unless (-d $dir)
 173             {
 174                 mkpath ($dir, 0, 0755);
 175             }
 176         }
 177
 178         my (undef, $heatmap_file)     = tempfile( "heatmap_${pop_id}-XXXXXX",
 179                                                   DIR      => $corre_temp_dir,
 180                                                   SUFFIX   => '.png',
 181                                                   UNLINK   => 0,
 182                                                 );
 183
 184         my (undef, $corre_table_file) = tempfile( "corre_table_${pop_id}-XXXXXX",
 185                                                   DIR      => $corre_temp_dir,
 186                                                   SUFFIX   => '.txt',
 187                                                   UNLINK   => 0,
 188                                                 );
 189
 190         my ( $corre_commands_temp, $corre_output_temp ) =
 191             map
 192         {
 193             my ( undef, $filename ) =
 194                 tempfile(
 195                     File::Spec->catfile(
 196                         CXGN::Tools::Run->temp_base($corre_temp_dir),
 197                         "corre_pop_${pop_id}-$_-XXXXXX"
 198                          ),
 199                     UNLINK => 0,
 200                 );
 201             $filename
 202         } qw / in out /;
 203
 204         {
 205             my $corre_commands_file = $c->path_to('/cgi-bin/phenome/correlation.r');
 206             copy( $corre_commands_file, $corre_commands_temp )
 207                 or die "could not copy '$corre_commands_file' to '$corre_commands_temp'";
 208         }
 209         try
 210         {
 211             my $r_process = CXGN::Tools::Run->run_cluster(
 212                 'R', 'CMD', 'BATCH',
 213                 '--slave',
 214                 "--args $heatmap_file $corre_table_file $pheno_file",
 215                 $corre_commands_temp,
 216                 $corre_output_temp,
 217                 {
 218                     working_dir => $corre_temp_dir,
 219                     max_cluster_jobs => 1_000_000_000,
 220                 },
 221                 );
 222
 223             $r_process->wait;
 224        }
 225         catch
 226         {
 227             my $err = $_;
 228             $err =~ s/\n at .+//s; #< remove any additional backtrace
 229             #     # try to append the R output
 230             try{ $err .= "\n=== R output ===\n".file($corre_output_temp)->slurp."\n=== end R output ===\n" };
 231             # die with a backtrace
 232             Carp::confess $err;
 233         };
 234
 235         copy( $heatmap_file, $corre_image_dir )
 236             or die "could not copy $heatmap_file to $corre_image_dir";
 237         copy( $corre_table_file, $corre_image_dir )
 238             or die "could not copy $corre_table_file to $corre_image_dir";
 239
 240         $heatmap_file = fileparse($heatmap_file);
 241         $heatmap_file  = $c->generated_file_uri("correlation",  $heatmap_file);
 242         $corre_table_file = fileparse($corre_table_file);
 243         $corre_table_file  = $c->generated_file_uri("correlation",  $corre_table_file);
 244
 245         $c->stash( heatmap_file     => $heatmap_file,
 246                    corre_table_file => $corre_table_file
 247                 );
 248     }
 249 }
 250
 251 sub _correlation_output {
 252     my ($self, $c)      = @_;
 253     my $pop             = $c->{stash}->{pop};
 254     my $base_path       = $c->config->{basepath};
 255     my $temp_image_dir  = $c->config->{tempfiles_subdir};
 256     my $corre_image_dir = catfile($base_path, $temp_image_dir, "correlation");
 257     my $cache           = Cache::File->new( cache_root  => $corre_image_dir,
 258                                             cache_umask => 002
 259                                           );
 260     $cache->purge();
 261
 262     my $key_h           = "heat_" . $pop->get_population_id();
 263     my $key_t           = "corr_table_" . $pop->get_population_id();
 264     my $heatmap         = $cache->get($key_h);
 265     my $corre_table     = $cache->get($key_t);
 266
 267
 268     unless ($heatmap)
 269     {
 270         $self->_analyze_correlation($c);
 271         $heatmap = $c->stash->{heatmap_file};
 272         $corre_table  = $c->stash->{corre_table_file};
 273         $cache->set($key_h, "$heatmap", "24h");
 274         $cache->set($key_t, "$corre_table", "24h");
 275
 276     }
 277
 278     $heatmap     = undef if -z $c->get_conf('basepath')  . $heatmap;
 279     $corre_table = undef if -z $c->get_conf('basepath') . $corre_table;
 280
 281     $c->stash( heatmap_file     => $heatmap,
 282                corre_table_file => $corre_table,
 283         );
 284
 285     $self->_get_trait_acronyms($c) if $heatmap;
 286 }
 287
 288
 289 sub _list_traits {
 290     my ($self, $c) = @_;
 291     my $population_id = $c->stash->{pop}->get_population_id();
 292     my @phenotype;
 293
 294     if ($c->stash->{pop}->get_web_uploaded())
 295     {
 296         my @traits = $c->stash->{pop}->get_cvterms();
 297
 298         foreach my $trait (@traits)
 299         {
 300             my $trait_id   = $trait->get_user_trait_id();
 301             my $trait_name = $trait->get_name();
 302             my $definition = $trait->get_definition();
 303
 304             my ($min, $max, $avg, $std, $count)= $c->stash->{pop}->get_pop_data_summary($trait_id);
 305
 306             $c->stash( trait_id   => $trait_id,
 307                        trait_name => $trait_name
 308                 );
 309
 310             my $schema = $c->dbic_schema('Bio::Chado::Schema', 'sgn_chado');
 311             my $cvterm = $schema->resultset('Cv::Cvterm')->find(name => $trait_name);
 312             my $trait_link;
 313
 314             if ($cvterm)
 315             {
 316                 $c->stash(cvterm_id =>$cvterm->id);
 317                 $self->_link($c);
 318                 $trait_link = $c->stash->{cvterm_page};
 319             } else
 320             {
 321                 $self->_link($c);
 322                 $trait_link = $c->stash->{trait_page};
 323             }
 324
 325             my $qtl_analysis_page = $c->stash->{qtl_analysis_page};
 326             push  @phenotype,  [ map { $_ } ( $trait_link, $min, $max, $avg, $count, $qtl_analysis_page ) ];
 327         }
 328     }
 329     else
 330     {
 331         my @cvterms = $c->stash->{pop}->get_cvterms();
 332         foreach my $cvterm( @cvterms )
 333         {
 334             my $cvterm_id = $cvterm->get_cvterm_id();
 335             my $cvterm_name = $cvterm->get_cvterm_name();
 336             my ($min, $max, $avg, $std, $count)= $c->stash->{pop}->get_pop_data_summary($cvterm_id);
 337
 338             $c->stash( trait_name => $cvterm_name,
 339                        cvterm_id  => $cvterm_id
 340                 );
 341
 342             $self->_link($c);
 343             my $graph_icon = $c->stash->{graph_icon};
 344             my $qtl_analysis_page = $c->stash->{qtl_analysis_page};
 345             my $cvterm_page = $c->stash->{cvterm_page};
 346             push  @phenotype,  [ map { $_ } ( $cvterm_page, $min, $max, $avg, $count, $qtl_analysis_page ) ];
 347         }
 348     }
 349     $c->stash->{traits_list} = \@phenotype;
 350 }
 351
 352
 353 sub _is_qtl_pop {
 354     my ($self, $c, $id) = @_;
 355     my $qtltool = CXGN::Phenome::Qtl::Tools->new();
 356     my @qtl_pops = $qtltool->has_qtl_data();
 357
 358     foreach my $qtl_pop ( @qtl_pops )
 359     {
 360         my $pop_id = $qtl_pop->get_population_id();
 361         if ($pop_id == $id)
 362         {
 363             $c->stash->{is_qtl_pop} = 1;
 364             last;
 365         }
 366     }
 367 }
 368
 369
 370 sub _link {
 371     my ($self, $c) = @_;
 372     my $pop_id     = $c->stash->{pop}->get_population_id();
 373
 374     {
 375         no warnings 'uninitialized';
 376         my $trait_id   = $c->stash->{trait_id};
 377         my $cvterm_id  = $c->stash->{cvterm_id};
 378         my $trait_name = $c->stash->{trait_name};
 379         my $term_id    = $trait_id ? $trait_id : $cvterm_id;
 380         my $graph_icon = qq | <img src="/../../../documents/img/pop_graph.png" alt="run solqtl"/> |;
 381
 382         $self->_get_owner_details($c);
 383         my $owner_name = $c->stash->{owner_name};
 384         my $owner_id   = $c->stash->{owner_id};
 385
 386
 387         $c->stash( cvterm_page        => qq |<a href="/chado/cvterm.pl?cvterm_id=$cvterm_id">$trait_name</a> |,
 388                    trait_page         => qq |<a href="/phenome/trait.pl?trait_id=$trait_id">$trait_name</a> |,
 389                    owner_page         => qq |<a href="/solpeople/personal-info.pl?sp_person_id=$owner_id">$owner_name</a> |,
 390                    guideline          => $self->guideline,
 391                    phenotype_download => qq |<a href="/qtl/download/phenotype/$pop_id">Phenotype data</a> |,
 392                    genotype_download  => qq |<a href="/qtl/download/genotype/$pop_id">Genotype data</a> |,
 393                    corre_download     => qq |<a href="/qtl/download/correlation/$pop_id">Correlation data</a> |,
 394                    acronym_download   => qq |<a href="/qtl/download/acronym/$pop_id">Trait-acronym key</a> |,
 395                    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> |,
 396             );
 397     }
 398
 399 }
 400
 401 sub _get_trait_acronyms {
 402     my ($self, $c) = @_;
 403     $c->stash(trait_acronym_pairs => $c->stash->{pop}->get_cvterm_acronyms());
 404 }
 405
 406 sub _get_owner_details {
 407     my ($self, $c) = @_;
 408     my $owner_id   = $c->stash->{pop}->get_sp_person_id();
 409     my $owner      = CXGN::People::Person->new($c->dbc->dbh, $owner_id);
 410     my $owner_name = $owner->get_first_name()." ".$owner->get_last_name();
 411
 412     $c->stash( owner_name => $owner_name,
 413                owner_id   => $owner_id
 414         );
 415
 416 }
 417
 418 sub _show_data {
 419     my ($self, $c) = @_;
 420     my $user_id    = $c->stash->{userid};
 421     my $user_type  = $c->user->get_object->get_user_type() if $c->user;
 422     my $is_public  = $c->stash->{pop}->get_privacy_status();
 423     my $owner_id   = $c->stash->{pop}->get_sp_person_id();
 424
 425     if ($user_id)
 426     {
 427         ($user_id == $owner_id || $user_type eq 'curator') ? $c->stash(show_data => 1)
 428                   :                                          $c->stash(show_data => undef)
 429                   ;
 430     } else
 431     {
 432         $is_public ? $c->stash(show_data => 1)
 433                    : $c->stash(show_data => undef)
 434                    ;
 435     }
 436 }
 437
 438 sub search_help : PathPart('search/qtl/help') Chained Args(0) {
 439     my ($self, $c) = @_;
 440     $c->stash(template => '/qtl/search/help/index.mas')
 441 }
 442
 443 sub set_stat_option : PathPart('qtl/stat/option') Chained Args(0) {
 444     my ($self, $c)  = @_;
 445     my $pop_id      = $c->req->param('pop_id');
 446     my $stat_params = $c->req->param('stat_params');
 447     my $file        = $self->stat_options_file($c, $pop_id);
 448
 449     if ($file)
 450     {
 451         my $f = file( $file )->openw
 452             or die "Can't create file: $! \n";
 453
 454         if ( $stat_params eq 'default' )
 455         {
 456             $f->print( "default parameters\tYes" );
 457         }
 458         else
 459         {
 460             $f->print( "default parameters\tNo" );
 461         }
 462     }
 463     $c->res->content_type('application/json');
 464     $c->res->body({undef});
 465
 466 }
 467
 468 sub stat_options_file {
 469     my ($self, $c, $pop_id) = @_;
 470     my $login_id            = $c->user()->get_object->get_sp_person_id() if $c->user;
 471
 472     if ($login_id)
 473     {
 474         my $qtl = CXGN::Phenome::Qtl->new($login_id);
 475         my ($temp_qtl_dir, $temp_user_dir) = $qtl->create_user_qtl_dir($c);
 476         return  catfile( $temp_user_dir, "stat_options_pop_${pop_id}.txt" );
 477     }
 478     else
 479     {
 480         return;
 481     }
 482 }
 483
 484
 485 sub qtl_form : PathPart('qtl/form') Chained Args {
 486     my ($self, $c, $type, $pop_id) = @_;
 487
 488     my $userid = $c->user()->get_object->get_sp_person_id() if $c->user;
 489
 490     unless ($userid)
 491     {
 492        $c->res->redirect($c->uri_for('/solpeople/login.pl'));
 493     }
 494
 495     $type = 'intro' if !$type;
 496
 497     if (!$pop_id and $type !~ /intro|pop_form/ )
 498     {
 499      $c->throw_404("Population id argument is missing");
 500     }
 501
 502     $c->stash( template => $self->get_template($c, $type),
 503                pop_id   => $pop_id,
 504                guide    => $self->guideline,
 505                referer  => $c->req->path,
 506                userid   => $userid
 507             );
 508
 509 }
 510
 511 sub templates {
 512     my $self = shift;
 513     my %template_of = ( intro      => '/qtl/qtl_form/intro.mas',
 514                         pop_form   => '/qtl/qtl_form/pop_form.mas',
 515                         pheno_form => '/qtl/qtl_form/pheno_form.mas',
 516                         geno_form  => '/qtl/qtl_form/geno_form.mas',
 517                         trait_form => '/qtl/qtl_form/trait_form.mas',
 518                         stat_form  => '/qtl/qtl_form/stat_form.mas',
 519                         confirm    => '/qtl/qtl_form/confirm.mas'
 520                       );
 521         return \%template_of;
 522 }
 523
 524
 525 sub get_template {
 526     my ($self, $c, $type) = @_;
 527     return $self->templates->{$type};
 528 }
 529
 530 sub guideline {
 531     my $self = shift;
 532     return qq |<a href="http://docs.google.com/View?id=dgvczrcd_1c479cgfb">Guidelines</a> |;
 533 }
 534
 535
 536 sub genetic_map {
 537     my ($self, $c)  = @_;
 538     my $mapv_id     = $c->stash->{pop}->mapversion_id();
 539     my $map         = CXGN::Map->new( $c->dbc->dbh, { map_version_id => $mapv_id } );
 540     my $map_name    = $map->get_long_name();
 541     my $map_sh_name = $map->get_short_name();
 542
 543     $c->stash( genetic_map => qq | <a href=/cview/map.pl?map_version_id=$mapv_id>$map_name ($map_sh_name)</a> | );
 544
 545 }
 546
 547 sub search_form : PathPart('qtl/search') Chained Args(0) {
 548     my ($self, $c) = @_;
 549     $c->res->redirect('/search/qtl');
 550 }
 551
 552 sub search_results : PathPart('qtl/search/results') Chained Args(0) {
 553     my ($self, $c) = @_;
 554     my $trait = $c->req->param('trait');
 555     $trait =~ s/(^\s+|\s+$)//g;
 556     $trait =~ s/\s+/ /g;
 557
 558     my $schema    = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado");
 559     my $rs = $schema->resultset("Cv::Cvterm")->search(
 560         { name => { 'LIKE' => '%'.$trait .'%'} },
 561         { columns => [ qw/ cvterm_id name definition/ ] },
 562         {page => $c->req->param('page') || 1,
 563          rows => 10
 564         }
 565         );
 566
 567     my $rows = $self->mark_qtl_traits($c, $rs);
 568
 569     $c->stash(template   => '/qtl/search/results.mas',
 570               data       => $rows,
 571               query      => $c->req->param('trait'),
 572               pager      => $rs->pager,
 573               page_links => sub {uri ( query => { trait => $c->req->param('trait'), page => shift } ) }
 574         );
 575 }
 576
 577 sub mark_qtl_traits {
 578     my ($self, $c, $rs) = @_;
 579     my @rows =();
 580
 581     if (!$rs->single)
 582     {
 583         return undef;
 584     }
 585     else
 586     {
 587         my $qtltool       = CXGN::Phenome::Qtl::Tools->new();
 588         my $yes_mark = qq |<font size=4 color="#0033FF"> &#10003;</font> |;
 589         my $no_mark  = qq |<font size=4 color="#FF0000"> X </font> |;
 590
 591         while (my $cv = $rs->next)
 592         {
 593             my $id   = $cv->cvterm_id;
 594             my $name = $cv->name;
 595             my $def  = $cv->definition;
 596
 597             if (  $qtltool->is_from_qtl( $id ) )
 598             {
 599                 push @rows, [ qq | <a href="/chado/cvterm.pl?cvterm_id=$id">$name</a> |, $def, $yes_mark ];
 600
 601             }
 602             else
 603             {
 604                 push @rows, [ qq | <a href="/chado/cvterm.pl?cvterm_id=$id">$name</a> |, $def, $no_mark ];
 605             }
 606         }
 607         return \@rows;
 608     }
 609 }
 610
 611
 612
 613
 614
 615
 616 ####
 617 1;
 618 ####