seedlot upload with accession synonyms. seedlot upload works to update existing seedlots
[sgn.git] / lib / SGN / Controller / Qtl.pm
blob33ac1b10843dd4e5526f3a09f9d0c2ec620e3073
1 =head1 NAME
3 SGN::Controller::Qtl- controller for solQTL
5 =cut
7 package SGN::Controller::Qtl;
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;
26 BEGIN { extends 'Catalyst::Controller'}
28 sub view : Path('/qtl/view') Args(1) {
29 my ($self, $c, $id) = @_;
30 $c->res->redirect("/qtl/population/$id");
35 sub population : Path('/qtl/population') Args(1) {
36 my ( $self, $c, $id) = @_;
38 if ( $id )
40 $self->is_qtl_pop($c, $id);
41 if ( $c->stash->{is_qtl_pop} )
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);
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,
54 my $size = -s $phenotype_file;
56 $self->_link($c);
57 $self->_show_data($c);
58 $self->_list_traits($c);
59 $self->genetic_map($c);
61 $self->_get_trait_acronyms($c);
64 else
66 $c->throw_404("$id is not a QTL population.");
69 else
71 $c->throw_404("There is no QTL population for $id");
76 sub download_phenotype : Path('/qtl/download/phenotype') Args(1) {
77 my ($self, $c, $id) = @_;
79 $c->throw_404("<strong>$id</strong> is not a valid population id") if $id =~ m/\D/;
81 $self->is_qtl_pop($c, $id);
82 if ($c->stash->{is_qtl_pop})
84 my $pop = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
85 my $phenotype_file = $pop->phenotype_file($c);
87 unless (!-e $phenotype_file || -s $phenotype_file <= 1)
89 my @pheno_data = map { s/,/\t/g; [ $_ ]; } read_file($phenotype_file);
91 $c->res->content_type("text/plain");
92 $c->res->body(join "", map{ $_->[0]} @pheno_data);
95 else
97 $c->throw_404("<strong>$id</strong> is not a QTL population id");
101 sub download_genotype : Path('/qtl/download/genotype') Args(1) {
102 my ($self, $c, $id) = @_;
104 $c->throw_404("<strong>$id</strong> is not a valid population id") if $id =~ m/\D/;
106 $self->is_qtl_pop($c, $id);
107 if ($c->stash->{is_qtl_pop})
110 my $pop = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
111 my $genotype_file = $pop->genotype_file($c);
113 unless (!-e $genotype_file || -s $genotype_file <= 1)
115 my @geno_data = map { s/,/\t/g; [ $_ ]; } read_file($genotype_file);
117 $c->res->content_type("text/plain");
118 $c->res->body(join "", map{ $_->[0]} @geno_data);
121 else
123 $c->throw_404("<strong>$id</strong> is not a QTL population id");
127 sub download_correlation : Path('/qtl/download/correlation') Args(1) {
128 my ($self, $c, $id) = @_;
130 $c->throw_404("<strong>$id</strong> is not a valid population id") if $id =~ m/\D/;
132 $self->is_qtl_pop($c, $id);
133 if ($c->stash->{is_qtl_pop})
136 my $corr_file = catfile($c->path_to($c->config->{cluster_shared_tempdir}), 'correlation', 'cache', "corre_coefficients_table_${id}");
138 unless (!-e $corr_file || -s $corr_file <= 1)
140 my @corr_data;
141 my $count=1;
143 foreach ( read_file($corr_file) )
145 if ($count==1) { $_ = "Traits\t" . $_;}
146 s/NA//g;
147 push @corr_data, [ $_ ] ;
148 $count++;
150 $c->res->content_type("text/plain");
151 $c->res->body(join "", map{ $_->[0] } @corr_data);
155 else
157 $c->throw_404("<strong>$id</strong> is not a QTL population id");
161 sub download_acronym : Path('/qtl/download/acronym') Args(1) {
162 my ($self, $c, $id) = @_;
164 $c->throw_404("<strong>$id</strong> is not a valid population id") if $id =~ m/\D/;
166 $self->is_qtl_pop($c, $id);
167 if ($c->stash->{is_qtl_pop})
169 my $pop = CXGN::Phenome::Population->new($c->dbc->dbh, $id);
170 my $acronym = $pop->get_cvterm_acronyms;
172 $c->res->content_type("text/plain");
173 $c->res->body(join "\n", map{ $_->[1] . "\t" . $_->[0] } @$acronym);
176 else
178 $c->throw_404("<strong>$id</strong> is not a QTL population id");
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");
193 if (-s $pheno_file)
195 mkpath ([$corre_temp_dir, $corre_image_dir], 0, 0755);
197 my ($fh_hm, $heatmap_file) = tempfile( "heatmap_${pop_id}-XXXXXX",
198 DIR => $corre_temp_dir,
199 SUFFIX => '.png',
200 UNLINK => 0,
202 $fh_hm->close;
204 print STDERR "\nheatmap tempfile: $heatmap_file\n";
206 my ($fh_ct, $corre_table_file) = tempfile( "corre_table_${pop_id}-XXXXXX",
207 DIR => $corre_temp_dir,
208 SUFFIX => '.txt',
209 UNLINK => 0,
211 $fh_ct->close;
213 print STDERR "\ncorrelation coefficients tempfile: $corre_table_file\n";
215 CXGN::Tools::Run->temp_base($corre_temp_dir);
216 my ($fh_out, $filename);
217 my ( $corre_commands_temp, $corre_output_temp ) =
220 ($fh_out, $filename ) =
221 tempfile(
222 File::Spec->catfile(
223 CXGN::Tools::Run->temp_base(),
224 "corre_pop_${pop_id}-$_-XXXXXX",
226 UNLINK => 0,
228 $filename
229 } qw / in out /;
231 $fh_out->close;
232 print STDERR "\ncorrelation r output tempfile: $corre_output_temp\n";
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'";
239 try
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,
249 working_dir => $corre_temp_dir,
250 max_cluster_jobs => 1_000_000_000,
254 $r_process->wait;
255 sleep 5;
256 print STDERR "\ndone with correlation analysis..\n";
258 catch
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;
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";
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);
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";
282 $c->stash( heatmap_file => $heatmap_file,
283 corre_table_file => $corre_table_file
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();
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);
302 print STDERR "\ncached heatmap file: $heatmap\n";
303 print STDERR "\ncached correlation coefficients files: $corre_table\n";
305 unless ($heatmap)
307 $self->_analyze_correlation($c);
309 $heatmap = $c->stash->{heatmap_file};
310 $corre_table = $c->stash->{corre_table_file};
312 $cache->set($key_h, $heatmap, "30 days");
313 $cache->set($key_t, $corre_table, "30 days");
316 $heatmap = undef if -z $c->config->{basepath} . $heatmap;
317 $corre_table = undef if -z $c->config->{basepath} . $corre_table;
319 $c->stash( heatmap_file => $heatmap,
320 corre_table_file => $corre_table,
323 $self->_get_trait_acronyms($c);
327 sub _list_traits {
328 my ($self, $c) = @_;
329 my $population_id = $c->stash->{pop}->get_population_id();
330 my @phenotype;
332 if ($c->stash->{pop}->get_web_uploaded())
334 my @traits = $c->stash->{pop}->get_cvterms();
336 foreach my $trait (@traits)
338 my $trait_id = $trait->get_user_trait_id();
339 my $trait_name = $trait->get_name();
340 my $definition = $trait->get_definition();
342 my ($min, $max, $avg, $std, $count) = $c->stash->{pop}->get_pop_data_summary($trait_id);
344 $c->stash( trait_id => $trait_id,
345 trait_name => $trait_name
348 $self->_link($c);
349 my $trait_link = $c->stash->{trait_page};
351 my $qtl_analysis_page = $c->stash->{qtl_analysis_page};
352 push @phenotype, [ map { $_ } ( $trait_link, $min, $max, $avg, $count, $qtl_analysis_page ) ];
355 else
357 my @cvterms = $c->stash->{pop}->get_cvterms();
358 foreach my $cvterm( @cvterms )
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);
364 $c->stash( trait_name => $cvterm_name,
365 cvterm_id => $cvterm_id
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 ) ];
374 $c->stash->{traits_list} = \@phenotype;
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();
383 foreach my $qtl_pop ( @qtl_pops )
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)
393 sub _link {
394 my ($self, $c) = @_;
395 my $pop_id = $c->stash->{pop}->get_population_id();
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"/> |;
405 $self->_get_owner_details($c);
406 my $owner_name = $c->stash->{owner_name};
407 my $owner_id = $c->stash->{owner_id};
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> |,
423 sub _get_trait_acronyms {
424 my ($self, $c) = @_;
426 $c->stash(trait_acronym_pairs => $c->stash->{pop}->get_cvterm_acronyms());
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();
436 $c->stash( owner_name => $owner_name,
437 owner_id => $owner_id
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();
449 if ($user_id)
451 ($user_id == $owner_id || $user_type eq 'curator') ? $c->stash(show_data => 1)
452 : $c->stash(show_data => undef)
454 } else
456 $is_public ? $c->stash(show_data => 1)
457 : $c->stash(show_data => undef)
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);
468 if ($file)
470 my $f = file( $file )->openw
471 or die "Can't create file: $! \n";
473 if ( $stat_params eq 'default' )
475 $f->print( "default parameters\tYes" );
477 else
479 $f->print( "default parameters\tNo" );
482 $c->res->content_type('application/json');
483 $c->res->body({undef});
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;
491 if ($login_id)
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" );
497 else
499 return;
504 sub qtl_form : PathPart('qtl/form') Chained Args {
505 my ($self, $c, $type, $pop_id) = @_;
507 my $userid = $c->user()->get_object->get_sp_person_id() if $c->user;
509 unless ($userid)
511 $c->res->redirect( '/solpeople/login.pl' );
514 $type = 'intro' if !$type;
516 if (!$pop_id and $type !~ /intro|pop_form/ )
518 $c->throw_404("Population id argument is missing");
521 if ($pop_id and $pop_id !~ /^([0-9]+)$/)
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>"
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
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'
548 return \%template_of;
552 sub get_template {
553 my ($self, $c, $type) = @_;
554 return $self->templates->{$type};
557 sub submission_guide : PathPart('qtl/submission/guide') Chained Args(0) {
558 my ($self, $c) = @_;
559 $c->stash(template => '/qtl/submission/guide/index.mas');
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();
569 $c->stash( genetic_map => qq | <a href=/cview/map.pl?map_version_id=$mapv_id>$map_name ($map_sh_name)</a> | );
573 sub search_help : PathPart('qtl/search/help') Chained Args(0) {
574 my ($self, $c) = @_;
575 $c->stash(template => '/qtl/search/help/index.mas');
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;
584 my $rs = $self->search_qtl_traits($c, $trait);
586 if ($rs)
588 my $rows = $self->mark_qtl_traits($c, $rs);
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 } ) }
597 else
599 $c->stash(template => '/qtl/search/results.mas',
600 data => undef,
601 query => undef,
602 pager => undef,
603 page_links => undef,
608 sub search_qtl_traits {
609 my ($self, $c, $trait) = @_;
611 my $rs;
612 if ($trait)
614 my $schema = $c->dbic_schema("Bio::Chado::Schema");
615 my $cv_id = $schema->resultset("Cv::Cv")->search(
616 {name => 'solanaceae_phenotype'}
617 )->single->cv_id;
619 $rs = $schema->resultset("Cv::Cvterm")->search(
620 { name => { 'LIKE' => '%'.$trait .'%'},
621 cv_id => $cv_id,
624 columns => [ qw/ cvterm_id name definition / ]
627 page => $c->req->param('page') || 1,
628 rows => 10,
629 order_by => 'name'
633 return $rs;
636 sub mark_qtl_traits {
637 my ($self, $c, $rs) = @_;
638 my @rows =();
640 if (!$rs->single)
642 return undef;
644 else
646 my $qtltool = CXGN::Phenome::Qtl::Tools->new();
647 my $yes_mark = qq |<font size=4 color="#0033FF"> &#10003;</font> |;
648 my $no_mark = qq |<font size=4 color="#FF0000"> X </font> |;
650 while (my $cv = $rs->next)
652 my $id = $cv->cvterm_id;
653 my $name = $cv->name;
654 my $def = $cv->definition;
656 if ( $qtltool->is_from_qtl( $id ) )
658 push @rows, [ qq | <a href="/cvterm/$id/view">$name</a> |, $def, $yes_mark ];
661 else
663 push @rows, [ qq | <a href="/cvterm/$id/view">$name</a> |, $def, $no_mark ];
666 return \@rows;
671 sub qtl_traits : PathPart('qtl/traits') Chained Args(1) {
672 my ($self, $c, $index) = @_;
674 if ($index =~ /^\w{1}$/)
676 my $traits_list = $self->map_qtl_traits($c, $index);
678 $c->stash( template => '/qtl/traits/index.mas',
679 index => $index,
680 traits_list => $traits_list
683 else
685 $c->res->redirect('/search/qtl');
689 sub all_qtl_traits : PathPart('qtl/traits') Chained Args(0) {
690 my ($self, $c) = @_;
691 $c->res->redirect('/search/qtl');
694 sub filter_qtl_traits {
695 my ($self, $index) = @_;
697 my $qtl_tools = CXGN::Phenome::Qtl::Tools->new();
698 my ( $all_traits, $all_trait_d ) = $qtl_tools->all_traits_with_qtl_data();
700 return [
701 sort { $a cmp $b }
702 grep { /^$index/i }
703 uniq @$all_traits
707 sub map_qtl_traits {
708 my ($self, $c, $index) = @_;
710 my $traits_list = $self->filter_qtl_traits($index);
712 my @traits_urls;
713 if (@{$traits_list})
715 foreach my $trait (@{$traits_list})
717 my $cvterm = CXGN::Chado::Cvterm::get_cvterm_by_name( $c->dbc->dbh, $trait );
718 my $cvterm_id = $cvterm->get_cvterm_id();
719 if ($cvterm_id)
721 push @traits_urls,
723 map { $_ }
725 qq |<a href=/cvterm/$cvterm_id/view>$trait</a> |
729 else
731 my $t = CXGN::Phenome::UserTrait->new_with_name( $c->dbc->dbh, $trait );
732 my $trait_id = $t->get_user_trait_id();
733 push @traits_urls,
735 map { $_ }
737 qq |<a href=/phenome/trait.pl?trait_id=$trait_id>$trait</a> |
744 return \@traits_urls;
747 __PACKAGE__->meta->make_immutable;
748 ####
750 ####