lib/SGN/Controller/solGS/solGS.pm

   1 package SGN::Controller::solGS::solGS;
   2
   3 use Moose;
   4 use namespace::autoclean;
   5
   6 use String::CRC;
   7 use URI::FromHash 'uri';
   8 use File::Path qw / mkpath  /;
   9 use File::Spec::Functions qw / catfile catdir/;
  10 use File::Temp qw / tempfile tempdir /;
  11 use File::Slurp qw /write_file read_file/;
  12 use File::Copy;
  13 use File::Basename;
  14 use Cache::File;
  15 use Try::Tiny;
  16 use List::MoreUtils qw /uniq/;
  17
  18 #use Scalar::Util qw /weaken reftype/;
  19 use Statistics::Descriptive;
  20 use Math::Round::Var;
  21 use Algorithm::Combinatorics qw /combinations/;
  22 use Array::Utils qw(:all);
  23 use CXGN::Tools::Run;
  24 use JSON;
  25 use Storable qw/ nstore retrieve /;
  26 use Carp qw/ carp confess croak /;
  27 use SGN::Controller::solGS::Utils;
  28
  29 BEGIN { extends 'Catalyst::Controller' }
  30
  31 # Sets the actions in this controller to be registered with no prefix
  32 # so they function identically to actions created in MyApp.pm
  33 #
  34
  35 #__PACKAGE__->config(namespace => '');
  36
  37 =head1 NAME
  38
  39 solGS::Controller::Root - Root Controller for solGS
  40
  41 =head1 DESCRIPTION
  42
  43 [enter your description here]
  44
  45 =head1 METHODS
  46
  47 =head2 index
  48
  49 The root page (/)
  50
  51 =cut
  52
  53 sub population : Path('/solgs/population') Args() {
  54     my ( $self, $c, $training_pop_id, $gp, $protocol_id ) = @_;
  55
  56     if ( !$training_pop_id ) {
  57         $c->stash->{message} =
  58           "You can not access this page with out population id.";
  59         $c->stash->{template} = "/generic_message.mas";
  60     }
  61
  62     $c->controller('solGS::genotypingProtocol')
  63       ->stash_protocol_id( $c, $protocol_id );
  64
  65     $c->stash->{training_pop_id} = $training_pop_id;
  66
  67     if ( $training_pop_id =~ /dataset/ ) {
  68         $c->stash->{dataset_id} = $training_pop_id =~ s/\w+_//r;
  69     }
  70     elsif ( $training_pop_id =~ /list/ ) {
  71         $c->stash->{list_id} = $training_pop_id =~ s/\w+_//r;
  72     }
  73
  74     my $cached = $c->controller('solGS::CachedResult')
  75       ->check_single_trial_training_data( $c, $training_pop_id, $protocol_id );
  76
  77     if ( !$cached ) {
  78         $c->stash->{message} =
  79 "Cached output for this training population  does not exist anymore.\n"
  80           . "Please go to <a href=\"/solgs/search/\">the search page</a>"
  81           . " and create the training population data.";
  82
  83         $c->stash->{template} = "/generic_message.mas";
  84     }
  85     else {
  86         $c->controller('solGS::Utils')->save_metadata($c);
  87         $c->controller('solGS::Trait')->get_all_traits( $c, $training_pop_id );
  88
  89         $c->controller('solGS::Search')
  90           ->project_description( $c, $training_pop_id );
  91         $c->stash->{training_pop_name} = $c->stash->{project_name};
  92         $c->stash->{training_pop_desc} = $c->stash->{project_desc};
  93
  94         my $trial_page_url =
  95           $c->controller('solGS::Path')->trial_page_url($training_pop_id);
  96         $c->stash->{trial_detail_page} = $c->controller('solGS::Path')
  97           ->create_hyperlink( $trial_page_url, 'See trial detail' );
  98
  99         $c->stash->{analysis_type} =
 100           $c->controller('solGS::Path')->page_type($c);
 101
 102         $c->stash->{template} = $c->controller('solGS::Files')
 103           ->template('/population/training_population.mas');
 104     }
 105
 106 }
 107
 108 sub get_markers_count {
 109     my ( $self, $c, $pop_hash ) = @_;
 110
 111     my $geno_file;
 112     my $protocol_id = $c->stash->{genotyping_protocol_id};
 113
 114     if ( $pop_hash->{training_pop} ) {
 115         my $training_pop_id = $pop_hash->{training_pop_id};
 116         $c->stash->{pop_id} = $training_pop_id;
 117         $c->controller('solGS::Files')
 118           ->filtered_training_genotype_file( $c, $training_pop_id,
 119             $protocol_id );
 120         $geno_file = $c->stash->{filtered_training_genotype_file};
 121
 122         if ( !-s $geno_file ) {
 123             if ( $pop_hash->{data_set_type} =~ /combined_populations/ ) {
 124                 $c->controller('solGS::combinedTrials')
 125                   ->get_combined_pops_list( $c, $training_pop_id );
 126                 my $pops_list = $c->stash->{combined_pops_list};
 127                 $training_pop_id = $pops_list->[0];
 128             }
 129
 130             $c->controller('solGS::Files')
 131               ->genotype_file_name( $c, $training_pop_id, $protocol_id );
 132             $geno_file = $c->stash->{genotype_file_name};
 133         }
 134     }
 135     elsif ( $pop_hash->{selection_pop} ) {
 136         my $selection_pop_id = $pop_hash->{selection_pop_id};
 137         $c->stash->{selection_pop_id} = $selection_pop_id;
 138         $c->controller('solGS::Files')->filtered_selection_genotype_file($c);
 139         $geno_file = $c->stash->{filtered_selection_genotype_file};
 140
 141         if ( !-s $geno_file ) {
 142             $c->controller('solGS::Files')
 143               ->genotype_file_name( $c, $selection_pop_id, $protocol_id );
 144             $geno_file = $c->stash->{genotype_file_name};
 145         }
 146     }
 147
 148     my $markers     = qx / head -n 1 $geno_file /;
 149     my $markers_cnt = split( /\t/, $markers ) - 1;
 150
 151     return $markers_cnt;
 152
 153 }
 154
 155 sub count_predicted_lines {
 156     my ( $self, $c, $args ) = @_;
 157
 158     my $training_pop_id  = $args->{training_pop_id};
 159     my $selection_pop_id = $args->{selection_pop_id};
 160     my $trait_id         = $args->{trait_id};
 161
 162     my $gebvs_file;
 163     if ( !$selection_pop_id ) {
 164         $c->controller('solGS::Files')
 165           ->rrblup_training_gebvs_file( $c, $training_pop_id, $trait_id );
 166         $gebvs_file = $c->stash->{rrblup_training_gebvs_file};
 167     }
 168     elsif ( $selection_pop_id && $training_pop_id ) {
 169         $c->controller('solGS::Files')
 170           ->rrblup_selection_gebvs_file( $c, $training_pop_id,
 171             $selection_pop_id, $trait_id );
 172         $gebvs_file = $c->stash->{rrblup_selection_gebvs_file};
 173     }
 174
 175     my $count = $c->controller('solGS::Utils')->count_data_rows($gebvs_file);
 176
 177     return $count;
 178 }
 179
 180 sub training_pop_lines_count {
 181     my ( $self, $c, $training_pop_id, $protocol_id ) = @_;
 182
 183     $c->stash->{genotyping_protocol_id} = $protocol_id;
 184
 185     my $genotypes_file;
 186     if ( $c->req->path =~ /solgs\/trait\// ) {
 187         my $trait_id = $c->stash->{trait_id};
 188         $c->controller('solGS::Files')
 189           ->rrblup_training_gebvs_file( $c, $training_pop_id, $trait_id );
 190         $genotypes_file = $c->stash->{rrblup_training_gebvs_file};
 191     }
 192     else {
 193         $c->controller('solGS::Files')
 194           ->genotype_file_name( $c, $training_pop_id, $protocol_id );
 195         $genotypes_file = $c->stash->{genotype_file_name};
 196     }
 197
 198     my $count =
 199       $c->controller('solGS::Utils')->count_data_rows($genotypes_file);
 200
 201     return $count;
 202 }
 203
 204 sub check_training_pop_size : Path('/solgs/check/training/pop/size') Args(0) {
 205     my ( $self, $c ) = @_;
 206
 207     my $args = $c->req->param('args');
 208
 209     my $json = JSON->new();
 210     $args = $json->decode($args);
 211
 212     my $pop_id      = @{ $args->{training_pop_id} }[0];
 213     my $type        = $args->{data_set_type};
 214     my $protocol_id = $args->{genotyping_protocol_id};
 215
 216     $c->controller('solGS::genotypingProtocol')
 217       ->stash_protocol_id( $c, $protocol_id );
 218
 219     my $count;
 220     if ( $type =~ /single/ ) {
 221         $count = $self->training_pop_lines_count( $c, $pop_id, $protocol_id );
 222     }
 223     elsif ( $type =~ /combined/ ) {
 224         $c->stash->{combo_pops_id} = $pop_id;
 225         $count = $c->controller('solGS::combinedTrials')
 226           ->count_combined_trials_lines( $c, $pop_id, $protocol_id );
 227     }
 228
 229     my $ret->{status} = 'failed';
 230
 231     if ($count) {
 232         $ret->{status}       = 'success';
 233         $ret->{member_count} = $count;
 234     }
 235
 236     $ret = to_json($ret);
 237
 238     $c->res->content_type('application/json');
 239     $c->res->body($ret);
 240
 241 }
 242
 243 sub selection_trait : Path('/solgs/selection/') Args() {
 244     my (
 245         $self,      $c,               $selection_pop_id,
 246         $model_key, $training_pop_id, $trait_key,
 247         $trait_id,  $gp,              $protocol_id
 248     ) = @_;
 249
 250     $c->controller('solGS::Trait')->get_trait_details( $c, $trait_id );
 251     my $trait_abbr = $c->stash->{trait_abbr};
 252
 253     $c->stash->{training_pop_id}  = $training_pop_id;
 254     $c->stash->{selection_pop_id} = $selection_pop_id;
 255     $c->stash->{data_set_type}    = 'single_population';
 256     $c->controller('solGS::genotypingProtocol')
 257       ->stash_protocol_id( $c, $protocol_id );
 258     $protocol_id = $c->stash->{genotyping_protocol_id};
 259
 260     $c->controller('solGS::Files')
 261       ->rrblup_selection_gebvs_file( $c, $training_pop_id, $selection_pop_id,
 262         $trait_id );
 263     my $gebvs_file = $c->stash->{rrblup_selection_gebvs_file};
 264
 265     my $args = {
 266         'trait_id'               => $trait_id,
 267         'training_pop_id'        => $training_pop_id,
 268         'genotyping_protocol_id' => $protocol_id,
 269         'data_set_type'          => 'single_population'
 270     };
 271
 272     my $model_page = $c->controller('solGS::Path')->model_page_url($args);
 273
 274     if ( !-s $gebvs_file ) {
 275         $model_page = $c->controller('solGS::Path')
 276           ->create_hyperlink( $model_page, 'training model page' );
 277
 278         $c->stash->{message} = "No cached output was found for this trait.\n"
 279           . " Please go to the $model_page and run the prediction.";
 280
 281         $c->stash->{template} = "/generic_message.mas";
 282     }
 283     else {
 284         if ( $training_pop_id =~ /list/ ) {
 285             $c->stash->{list_id} = $training_pop_id =~ s/\w+_//r;
 286             $c->controller('solGS::List')->list_population_summary($c);
 287             $c->stash->{training_pop_id}    = $c->stash->{project_id};
 288             $c->stash->{training_pop_name}  = $c->stash->{project_name};
 289             $c->stash->{training_pop_desc}  = $c->stash->{project_desc};
 290             $c->stash->{training_pop_owner} = $c->stash->{owner};
 291         }
 292         elsif ( $training_pop_id =~ /dataset/ ) {
 293             $c->stash->{dataset_id} = $training_pop_id =~ s/\w+_//r;
 294             $c->controller('solGS::Dataset')->dataset_population_summary($c);
 295             $c->stash->{training_pop_id}    = $c->stash->{project_id};
 296             $c->stash->{training_pop_name}  = $c->stash->{project_name};
 297             $c->stash->{training_pop_desc}  = $c->stash->{project_desc};
 298             $c->stash->{training_pop_owner} = $c->stash->{owner};
 299         }
 300         else {
 301             $c->controller('solGS::Search')
 302               ->get_project_details( $c, $training_pop_id );
 303             $c->stash->{training_pop_id}   = $c->stash->{project_id};
 304             $c->stash->{training_pop_name} = $c->stash->{project_name};
 305             $c->stash->{training_pop_desc} = $c->stash->{project_desc};
 306
 307             $c->controller('solGS::Search')
 308               ->get_project_owners( $c, $training_pop_id );
 309             $c->stash->{training_pop_owner} = $c->stash->{project_owners};
 310         }
 311
 312         if ( $selection_pop_id =~ /list/ ) {
 313             $c->stash->{list_id} = $selection_pop_id =~ s/\w+_//r;
 314
 315             $c->controller('solGS::List')->list_population_summary($c);
 316             $c->stash->{selection_pop_id}    = $c->stash->{project_id};
 317             $c->stash->{selection_pop_name}  = $c->stash->{project_name};
 318             $c->stash->{selection_pop_desc}  = $c->stash->{project_desc};
 319             $c->stash->{selection_pop_owner} = $c->stash->{owner};
 320         }
 321         elsif ( $selection_pop_id =~ /dataset/ ) {
 322             $c->stash->{dataset_id} = $selection_pop_id =~ s/\w+_//r;
 323             $c->controller('solGS::Dataset')->dataset_population_summary($c);
 324             $c->stash->{selection_pop_id}    = $c->stash->{project_id};
 325             $c->stash->{selection_pop_name}  = $c->stash->{project_name};
 326             $c->stash->{selection_pop_desc}  = $c->stash->{project_desc};
 327             $c->stash->{selection_pop_owner} = $c->stash->{owner};
 328         }
 329         else {
 330             $c->controller('solGS::Search')
 331               ->get_project_details( $c, $selection_pop_id );
 332             $c->stash->{selection_pop_id}   = $c->stash->{project_id};
 333             $c->stash->{selection_pop_name} = $c->stash->{project_name};
 334             $c->stash->{selection_pop_desc} = $c->stash->{project_desc};
 335
 336             $c->controller('solGS::Search')
 337               ->get_project_owners( $c, $selection_pop_id );
 338             $c->stash->{selection_pop_owner} = $c->stash->{project_owners};
 339         }
 340
 341         my $tr_pop_mr_cnt = $self->get_markers_count( $c,
 342             { 'training_pop' => 1, 'training_pop_id' => $training_pop_id } );
 343         my $sel_pop_mr_cnt = $self->get_markers_count( $c,
 344             { 'selection_pop' => 1, 'selection_pop_id' => $selection_pop_id } );
 345
 346         my $protocol_url = $c->controller('solGS::genotypingProtocol')
 347           ->create_protocol_url( $c, $protocol_id );
 348         $c->stash->{protocol_url} = $protocol_url;
 349
 350         $c->controller('solGS::Files')
 351           ->rrblup_selection_gebvs_file( $c, $training_pop_id,
 352             $selection_pop_id, $trait_id );
 353         my $gebvs_file = $c->stash->{rrblup_selection_gebvs_file};
 354
 355         my @stock_rows = read_file( $gebvs_file, { binmode => ':utf8' } );
 356         $c->stash->{selection_stocks_cnt}  = scalar(@stock_rows) - 1;
 357         $c->stash->{training_markers_cnt}  = $tr_pop_mr_cnt;
 358         $c->stash->{selection_markers_cnt} = $sel_pop_mr_cnt;
 359
 360         my $ma_args =
 361           { 'selection_pop' => 1, 'selection_pop_id' => $selection_pop_id };
 362         $c->stash->{selection_markers_cnt} =
 363           $self->get_markers_count( $c, $ma_args );
 364         my $protocol_url = $c->controller('solGS::genotypingProtocol')
 365           ->create_protocol_url( $c, $protocol_id );
 366         $c->stash->{protocol_url} = $protocol_url;
 367
 368         my $args = {
 369             'training_pop_id'  => $training_pop_id,
 370             'selection_pop_id' => $selection_pop_id,
 371             'trait_id'         => $trait_id
 372         };
 373
 374         $c->stash->{selection_stocks_cnt} =
 375           $self->count_predicted_lines( $c, $args );
 376
 377         $self->top_blups( $c, $gebvs_file );
 378         my $training_pop_name = $c->stash->{training_pop_name};
 379         my $model_link        = "$training_pop_name -- $trait_abbr";
 380         $model_page = $c->controller('solGS::Path')
 381           ->create_hyperlink( $model_page, $model_link );
 382         $c->stash->{model_page_url} = $model_page;
 383         $c->stash->{analysis_type} =
 384           $c->controller('solGS::Path')->page_type($c);
 385
 386         $c->stash->{template} = $c->controller('solGS::Files')
 387           ->template('/population/selection_prediction_detail.mas');
 388
 389     }
 390
 391 }
 392
 393 sub build_single_trait_model {
 394     my ( $self, $c ) = @_;
 395
 396     my $trait_id = $c->stash->{trait_id};
 397     $c->controller('solGS::Trait')->get_trait_details( $c, $trait_id );
 398
 399     $self->get_rrblup_output($c);
 400
 401 }
 402
 403 sub trait : Path('/solgs/trait') Args(5) {
 404     my ( $self, $c, $trait_id, $key, $training_pop_id, $gp, $protocol_id ) = @_;
 405
 406     if ( !$training_pop_id || !$trait_id ) {
 407         $c->stash->{message} =
 408           "You can not access this page with out population id or trait id.";
 409         $c->stash->{template} = "/generic_message.mas";
 410     }
 411
 412     if ( $training_pop_id =~ /dataset/ ) {
 413         $c->stash->{dataset_id} = $training_pop_id =~ s/\w+_//r;
 414     }
 415     elsif ( $training_pop_id =~ /list/ ) {
 416         $c->stash->{list_id} = $training_pop_id =~ s/\w+_//r;
 417     }
 418
 419 # $c->controller('solGS::genotypingProtocol')->stash_protocol_id($c, $protocol_id);
 420     $c->stash->{genotyping_protocol_id} = $protocol_id;
 421     $c->stash->{training_pop_id}        = $training_pop_id;
 422     $c->stash->{trait_id}               = $trait_id;
 423
 424     $c->controller('solGS::Search')
 425       ->project_description( $c, $training_pop_id );
 426     my $training_pop_name = $c->stash->{project_name};
 427     $c->stash->{training_pop_name} = $training_pop_name;
 428     $c->stash->{training_pop_desc} = $c->stash->{project_desc};
 429
 430     my $args = {
 431         'training_pop_id'        => $training_pop_id,
 432         'genotyping_protocol_id' => $protocol_id,
 433         'data_set_type'          => 'single_population'
 434     };
 435
 436     my $training_pop_url =
 437       $c->controller('solGS::Path')->training_page_url($args);
 438     my $training_pop_page = $c->controller('solGS::Path')
 439       ->create_hyperlink( $training_pop_url, $training_pop_name );
 440
 441     my $cached =
 442       $c->controller('solGS::CachedResult')
 443       ->check_single_trial_model_output( $c, $training_pop_id, $trait_id,
 444         $protocol_id );
 445
 446     if ( !$cached ) {
 447         $c->stash->{message} =
 448             "Cached output for this model does not exist anymore.\n"
 449           . " Please go to $training_pop_page and run the analysis.";
 450
 451         $c->stash->{template} = "/generic_message.mas";
 452     }
 453     else {
 454
 455         $c->controller('solGS::Trait')->get_trait_details( $c, $trait_id );
 456         my $trait_abbr = $c->stash->{trait_abbr};
 457
 458         $self->gs_modeling_files($c);
 459
 460         $c->controller('solGS::modelAccuracy')
 461           ->cross_validation_stat( $c, $training_pop_id, $trait_abbr );
 462         $c->controller('solGS::Files')
 463           ->traits_acronym_file( $c, $training_pop_id );
 464         my $acronym_file = $c->stash->{traits_acronym_file};
 465
 466         if ( !-e $acronym_file || !-s $acronym_file ) {
 467             $c->controller('solGS::Trait')
 468               ->get_all_traits( $c, $training_pop_id );
 469         }
 470
 471         $self->model_phenotype_stat($c);
 472
 473         $c->stash->{training_pop_url} = $training_pop_page;
 474
 475         my $trial_page_url =
 476           $c->controller('solGS::Path')->trial_page_url($training_pop_id);
 477         $c->stash->{trial_detail_page} = $c->controller('solGS::Path')
 478           ->create_hyperlink( $trial_page_url, 'See trial detail' );
 479
 480         $c->stash->{analysis_type} =
 481           $c->controller('solGS::Path')->page_type($c);
 482
 483         $c->stash->{template} = $c->controller('solGS::Files')
 484           ->template("/population/models/model/detail.mas");
 485     }
 486
 487 }
 488
 489 sub gs_modeling_files {
 490     my ( $self, $c ) = @_;
 491
 492     $self->output_files($c);
 493     $self->input_files($c);
 494     $c->controller('solGS::modelAccuracy')->model_accuracy_report($c);
 495     $self->top_blups( $c, $c->stash->{rrblup_training_gebvs_file} );
 496     $self->top_markers( $c, $c->stash->{marker_effects_file} );
 497     $self->variance_components($c);
 498
 499 }
 500
 501 sub save_model_info_file {
 502     my ( $self, $c ) = @_;
 503
 504     my $protocol_id = $c->stash->{genotyping_protocol_id};
 505     my $protocol_url =
 506       $c->req->base . 'breeders_toolbox/protocol/' . $protocol_id;
 507
 508     my %info_table = (
 509         'model_id'     => $c->stash->{training_pop_id},
 510         'protocol_id'  => $protocol_id,
 511         'protocol_url' => $protocol_url,
 512         'trait_abbr'   => $c->stash->{trait_abbr},
 513         'trait_name'   => $c->stash->{trait_name},
 514         'trait_id'     => $c->stash->{trait_id},
 515     );
 516
 517     my $info = 'Name' . "\t" . 'Value' . "\n";
 518
 519     while ( my ( $key, $val ) = each(%info_table) ) {
 520         $info .= $key . "\t" . $val . "\n";
 521     }
 522
 523     my $file = $c->controller('solGS::Files')->model_info_file($c);
 524     write_file( $file, { binmode => ':utf8' }, $info );
 525
 526 }
 527
 528 sub input_files {
 529     my ( $self, $c ) = @_;
 530
 531     if ( $c->stash->{data_set_type} =~ /combined_populations/i ) {
 532         $c->controller('solGS::combinedTrials')
 533           ->combined_pops_gs_input_files($c);
 534         my $input_file = $c->stash->{combined_pops_gs_input_files};
 535         $c->stash->{input_files} = $input_file;
 536     }
 537     else {
 538         my $training_pop_id = $c->stash->{training_pop_id};
 539         my $protocol_id     = $c->stash->{genotyping_protocol_id};
 540
 541         $self->save_model_info_file($c);
 542
 543         $c->controller('solGS::Files')
 544           ->genotype_file_name( $c, $training_pop_id, $protocol_id );
 545         my $geno_file = $c->stash->{genotype_file_name};
 546
 547         $c->controller('solGS::Files')
 548           ->phenotype_file_name( $c, $training_pop_id );
 549         my $pheno_file = $c->stash->{phenotype_file_name};
 550
 551         $c->controller('solGS::Files')->model_info_file($c);
 552         my $model_info_file = $c->stash->{model_info_file};
 553
 554         $c->controller('solGS::Files')->formatted_phenotype_file($c);
 555         my $formatted_phenotype_file = $c->stash->{formatted_phenotype_file};
 556
 557         my $selection_pop_id = $c->stash->{selection_pop_id};
 558         my ( $selection_population_file, $filtered_pred_geno_file );
 559
 560         if ($selection_pop_id) {
 561             $selection_population_file = $c->stash->{selection_population_file};
 562         }
 563
 564         my $trait_abbr  = $c->stash->{trait_abbr};
 565         my $traits_file = $c->stash->{selected_traits_file};
 566
 567         no warnings 'uninitialized';
 568
 569         my $input_files = join( "\t",
 570             $pheno_file, $formatted_phenotype_file, $geno_file, $traits_file,
 571             $model_info_file, $selection_population_file, );
 572
 573         my $name     = "input_files_${trait_abbr}_${training_pop_id}";
 574         my $temp_dir = $c->stash->{solgs_tempfiles_dir};
 575         my $tempfile =
 576           $c->controller('solGS::Files')->create_tempfile( $temp_dir, $name );
 577         write_file( $tempfile, { binmode => ':utf8' }, $input_files );
 578         $c->stash->{input_files} = $tempfile;
 579     }
 580 }
 581
 582 sub output_files {
 583     my ( $self, $c ) = @_;
 584
 585     my $training_pop_id = $c->stash->{pop_id};
 586     $training_pop_id = $c->stash->{model_id} || $c->stash->{training_pop_id}
 587       if !$training_pop_id;
 588
 589     my $page_type =
 590       $c->controller('solGS::Path')->page_type( $c, $c->req->referer );
 591     my $analysis_type = $c->stash->{analysis_type} || $page_type;
 592     $analysis_type =~ s/\s+/_/g;
 593
 594     my $trait_abbr = $c->stash->{trait_abbr};
 595     my $trait_id   = $c->stash->{trait_id};
 596     $c->stash->{cache_dir} = $c->stash->{solgs_cache_dir};
 597     $c->controller('solGS::Files')->marker_effects_file($c);
 598     $c->controller('solGS::Files')->rrblup_training_gebvs_file($c);
 599     $c->controller('solGS::Files')->validation_file($c);
 600     $c->controller("solGS::Files")->model_phenodata_file($c);
 601     $c->controller("solGS::Files")->model_genodata_file($c);
 602     $c->controller("solGS::Files")->trait_raw_phenodata_file($c);
 603     $c->controller("solGS::Files")->variance_components_file($c);
 604     $c->controller('solGS::Files')->relationship_matrix_file($c);
 605     $c->controller('solGS::Files')->relationship_matrix_adjusted_file($c);
 606     $c->controller('solGS::Files')->inbreeding_coefficients_file($c);
 607     $c->controller('solGS::Files')->average_kinship_file($c);
 608     $c->controller('solGS::Files')->filtered_training_genotype_file($c);
 609     $c->controller('solGS::Files')->analysis_report_file($c);
 610     $c->controller('solGS::Files')->genotype_filtering_log_file($c);
 611
 612     my $selection_pop_id = $c->stash->{selection_pop_id};
 613
 614     no warnings 'uninitialized';
 615
 616     if ($selection_pop_id) {
 617         $c->controller('solGS::Files')
 618           ->rrblup_selection_gebvs_file( $c, $training_pop_id,
 619             $selection_pop_id, $trait_id );
 620         $c->controller('solGS::Files')->filtered_selection_genotype_file($c);
 621     }
 622
 623     my $file_list = join( "\t",
 624         $c->stash->{rrblup_training_gebvs_file},
 625         $c->stash->{marker_effects_file},
 626         $c->stash->{validation_file},
 627         $c->stash->{model_phenodata_file},
 628         $c->stash->{model_genodata_file},
 629         $c->stash->{trait_raw_phenodata_file},
 630         $c->stash->{selected_traits_gebv_file},
 631         $c->stash->{variance_components_file},
 632         $c->stash->{relationship_matrix_table_file},
 633         $c->stash->{relationship_matrix_adjusted_table_file},
 634         $c->stash->{inbreeding_coefficients_file},
 635         $c->stash->{average_kinship_file},
 636         $c->stash->{relationship_matrix_json_file},
 637         $c->stash->{relationship_matrix_adjusted_json_file},
 638         $c->stash->{filtered_training_genotype_file},
 639         $c->stash->{filtered_selection_genotype_file},
 640         $c->stash->{rrblup_selection_gebvs_file},
 641         $c->stash->{"${analysis_type}_report_file"},
 642         $c->stash->{genotype_filtering_log_file},
 643     );
 644
 645     my $name = "output_files_${trait_abbr}_${training_pop_id}";
 646     $name .= "_${selection_pop_id}" if $selection_pop_id;
 647     my $temp_dir = $c->stash->{solgs_tempfiles_dir};
 648     my $tempfile =
 649       $c->controller('solGS::Files')->create_tempfile( $temp_dir, $name );
 650     write_file( $tempfile, { binmode => ':utf8' }, $file_list );
 651
 652     $c->stash->{output_files} = $tempfile;
 653
 654 }
 655
 656 sub top_markers {
 657     my ( $self, $c, $markers_file ) = @_;
 658
 659     $c->stash->{top_marker_effects} =
 660       $c->controller('solGS::Utils')->top_10($markers_file);
 661 }
 662
 663 sub top_blups {
 664     my ( $self, $c, $gebv_file ) = @_;
 665
 666     $c->stash->{top_blups} = $c->controller('solGS::Utils')->top_10($gebv_file);
 667 }
 668
 669 sub predict_selection_pop_single_trait {
 670     my ( $self, $c ) = @_;
 671
 672     if ( $c->stash->{data_set_type} =~ /single_population/ ) {
 673         $self->predict_selection_pop_single_pop_model($c);
 674     }
 675     else {
 676         $c->controller('solGS::combinedTrials')
 677           ->predict_selection_pop_combined_pops_model($c);
 678     }
 679
 680 }
 681
 682 sub predict_selection_pop_multi_traits {
 683     my ( $self, $c ) = @_;
 684
 685     my $data_set_type    = $c->stash->{data_set_type};
 686     my $training_pop_id  = $c->stash->{training_pop_id};
 687     my $selection_pop_id = $c->stash->{selection_pop_id};
 688     my $protocol_id      = $c->stash->{genotyping_protocol_id};
 689
 690     $c->stash->{pop_id} = $training_pop_id;
 691
 692     my @traits = @{ $c->stash->{training_traits_ids} }
 693       if $c->stash->{training_traits_ids};
 694
 695     $self->traits_with_valid_models($c);
 696     my @traits_with_valid_models =
 697       @{ $c->stash->{traits_ids_with_valid_models} };
 698
 699     $c->stash->{training_traits_ids} = \@traits_with_valid_models;
 700
 701     my @unpredicted_traits;
 702     foreach my $trait_id ( @{ $c->stash->{training_traits_ids} } ) {
 703         $c->controller('solGS::Files')
 704           ->rrblup_selection_gebvs_file( $c, $training_pop_id,
 705             $selection_pop_id, $trait_id );
 706
 707         push @unpredicted_traits, $trait_id
 708           if !-s $c->stash->{rrblup_selection_gebvs_file};
 709     }
 710
 711     if (@unpredicted_traits) {
 712         $c->stash->{training_traits_ids} = \@unpredicted_traits;
 713
 714         $c->controller('solGS::Files')
 715           ->genotype_file_name( $c, $selection_pop_id, $protocol_id );
 716
 717         if ( !-s $c->stash->{genotype_file_name} ) {
 718             $c->controller('solGS::AsyncJob')
 719               ->get_selection_pop_query_args_file($c);
 720             $c->stash->{prerequisite_jobs} =
 721               $c->stash->{selection_pop_query_args_file};
 722         }
 723
 724         $c->controller('solGS::Files')
 725           ->selection_population_file( $c, $selection_pop_id, $protocol_id );
 726
 727         $c->controller('solGS::AsyncJob')->get_gs_modeling_jobs_args_file($c);
 728         $c->stash->{dependent_jobs} = $c->stash->{gs_modeling_jobs_args_file};
 729
 730         #$c->stash->{prerequisite_type} = 'selection_pop_download_data';
 731
 732         $c->controller('solGS::AsyncJob')->run_async($c);
 733     }
 734     else {
 735         croak "No traits to predict: $!\n";
 736     }
 737
 738 }
 739
 740 sub predict_selection_pop_single_pop_model {
 741     my ( $self, $c ) = @_;
 742
 743     my $trait_id         = $c->stash->{trait_id};
 744     my $training_pop_id  = $c->stash->{training_pop_id};
 745     my $selection_pop_id = $c->stash->{selection_pop_id};
 746     my $protocol_id      = $c->stash->{genotyping_protocol_id};
 747
 748     $c->controller('solGS::Trait')->get_trait_details( $c, $trait_id );
 749     my $trait_abbr = $c->stash->{trait_abbr};
 750
 751     $c->controller('solGS::Files')
 752       ->rrblup_selection_gebvs_file( $c, $training_pop_id, $selection_pop_id,
 753         $trait_id );
 754
 755     my $rrblup_selection_gebvs_file = $c->stash->{rrblup_selection_gebvs_file};
 756
 757     if ( !-s $rrblup_selection_gebvs_file ) {
 758         $c->stash->{pop_id} = $training_pop_id;
 759         $c->controller('solGS::Files')
 760           ->phenotype_file_name( $c, $training_pop_id );
 761         my $pheno_file = $c->stash->{phenotype_file_name};
 762
 763         $c->controller('solGS::Files')
 764           ->genotype_file_name( $c, $training_pop_id, $protocol_id );
 765         my $geno_file = $c->stash->{genotype_file_name};
 766
 767         $c->stash->{pheno_file} = $pheno_file;
 768         $c->stash->{geno_file}  = $geno_file;
 769
 770         $c->controller('solGS::Files')
 771           ->selection_population_file( $c, $selection_pop_id, $protocol_id );
 772
 773         $self->get_rrblup_output($c);
 774     }
 775
 776 }
 777
 778 sub selection_prediction : Path('/solgs/model') Args() {
 779     my ( $self, $c, $training_pop_id, $pop, $selection_pop_id, $gp,
 780         $protocol_id )
 781       = @_;
 782
 783     my $referer = $c->req->referer;
 784     my $path    = $c->req->path;
 785     my $base    = $c->req->base;
 786     $referer =~ s/$base//;
 787
 788     $c->stash->{training_pop_id}  = $training_pop_id;
 789     $c->stash->{model_id}         = $training_pop_id;
 790     $c->stash->{pop_id}           = $training_pop_id;
 791     $c->stash->{selection_pop_id} = $selection_pop_id;
 792     $c->controller('solGS::genotypingProtocol')
 793       ->stash_protocol_id( $c, $protocol_id );
 794
 795     if ( $referer =~ /solgs\/model\/combined\/trials\// ) {
 796         my ( $combo_pops_id, $trait_id ) = $referer =~ m/(\d+)/g;
 797
 798         $c->stash->{data_set_type} = "combined_populations";
 799         $c->stash->{combo_pops_id} = $combo_pops_id;
 800         $c->stash->{trait_id}      = $trait_id;
 801
 802         $c->controller('solGS::combinedTrials')
 803           ->predict_selection_pop_combined_pops_model($c);
 804
 805         $c->controller('solGS::combinedTrials')->combined_pops_summary($c);
 806         $self->model_phenotype_stat($c);
 807         $self->gs_modeling_files($c);
 808
 809         my $args = {
 810             'trait_id'               => $trait_id,
 811             'training_pop_id'        => $combo_pops_id,
 812             'genotyping_protocol_id' => $protocol_id,
 813             'data_set_type'          => 'combined_populations'
 814         };
 815
 816         my $model_page = $c->controller('solGS::Path')->model_page_url($args);
 817         $c->res->redirect($model_page);
 818         $c->detach();
 819     }
 820     elsif ( $referer =~ /solgs\/trait\// ) {
 821         my ( $trait_id, $pop_id ) = $referer =~ m/(\d+)/g;
 822
 823         $c->stash->{data_set_type} = "single_population";
 824         $c->stash->{trait_id}      = $trait_id;
 825
 826         $self->predict_selection_pop_single_pop_model($c);
 827
 828         $self->model_phenotype_stat($c);
 829         $self->gs_modeling_files($c);
 830
 831         my $args = {
 832             'trait_id'               => $trait_id,
 833             'training_pop_id'        => $pop_id,
 834             'genotyping_protocol_id' => $protocol_id,
 835             'data_set_type'          => 'single_population'
 836         };
 837
 838         my $model_page = $c->controller('solGS::Path')->model_page_url($args);
 839
 840         $c->res->redirect($model_page);
 841         $c->detach();
 842     }
 843     elsif ( $referer =~ /solgs\/models\/combined\/trials/ ) {
 844         $c->stash->{data_set_type} = "combined_populations";
 845         $c->stash->{combo_pops_id} = $training_pop_id;
 846
 847         $self->traits_with_valid_models($c);
 848         my @traits_abbrs = @{ $c->stash->{traits_with_valid_models} };
 849
 850         foreach my $trait_abbr (@traits_abbrs) {
 851             $c->stash->{trait_abbr} = $trait_abbr;
 852             $c->controller('solGS::Trait')->get_trait_details_of_trait_abbr($c);
 853             $c->controller('solGS::combinedTrials')
 854               ->predict_selection_pop_combined_pops_model($c);
 855         }
 856
 857         $c->res->redirect(
 858             "/solgs/models/combined/trials/$training_pop_id/gp/$protocol_id");
 859         $c->detach();
 860     }
 861     elsif ( $referer =~ /solgs\/traits\/all\/population\// ) {
 862         $c->stash->{data_set_type} = "single_population";
 863
 864         $self->predict_selection_pop_multi_traits($c);
 865
 866         $c->res->redirect(
 867             "/solgs/traits/all/population/$training_pop_id/gp/$protocol_id");
 868         $c->detach();
 869     }
 870
 871 }
 872
 873 sub list_predicted_selection_pops {
 874     my ( $self, $c, $model_id ) = @_;
 875
 876     my $dir = $c->stash->{solgs_cache_dir};
 877
 878     opendir my $dh, $dir or die "can't open $dir: $!\n";
 879
 880     my @files =
 881       grep { /rrblup_selection_gebvs_\w+_${model_id}_/ && -f "$dir/$_" }
 882       readdir($dh);
 883
 884     closedir $dh;
 885
 886     my @pred_pops;
 887
 888     foreach (@files) {
 889         unless ( $_ =~ /list/ ) {
 890             my ( $model_id2, $pred_pop_id ) = $_ =~ m/\d+/g;
 891
 892             push @pred_pops, $pred_pop_id;
 893         }
 894     }
 895
 896     @pred_pops = uniq(@pred_pops);
 897
 898     $c->stash->{list_of_predicted_selection_pops} = \@pred_pops;
 899
 900 }
 901
 902 sub variance_components {
 903     my ( $self, $c ) = @_;
 904
 905     $c->controller("solGS::Files")->variance_components_file($c);
 906     my $file = $c->stash->{variance_components_file};
 907
 908     my $params = $c->controller('solGS::Utils')
 909       ->read_file_data( $file, { binmode => ':utf8' } );
 910     $c->stash->{variance_components} = $params;
 911
 912 }
 913
 914 sub selection_population_predicted_traits :
 915   Path('/solgs/selection/population/predicted/traits/') Args(0) {
 916     my ( $self, $c ) = @_;
 917
 918     my $args = $c->req->param('arguments');
 919     $c->controller('solGS::Utils')->stash_json_args( $c, $args );
 920
 921     my $training_pop_id  = $c->stash->{training_pop_id};
 922     my $selection_pop_id = $c->stash->{selection_pop_id};
 923
 924     my $ret->{selection_traits} = undef;
 925     if ( $training_pop_id && $selection_pop_id ) {
 926         $c->controller('solGS::Gebvs')
 927           ->selection_pop_analyzed_traits( $c, $training_pop_id,
 928             $selection_pop_id );
 929         my $selection_pop_traits =
 930           $c->stash->{selection_pop_analyzed_traits_ids};
 931         $ret->{selection_traits} = $selection_pop_traits;
 932
 933     }
 934
 935     $ret = to_json($ret);
 936
 937     $c->res->content_type('application/json');
 938     $c->res->body($ret);
 939
 940 }
 941
 942 sub build_multiple_traits_models {
 943     my ( $self, $c ) = @_;
 944
 945     my $pop_id          = $c->stash->{pop_id} || $c->stash->{training_pop_id};
 946     my @selected_traits = @{ $c->stash->{training_traits_ids} };
 947     my $trait_id        = $selected_traits[0] if scalar(@selected_traits) == 1;
 948
 949     my $traits;
 950
 951     for ( my $i = 0 ; $i <= $#selected_traits ; $i++ ) {
 952         my $tr = $c->controller('solGS::Search')->model($c)
 953           ->trait_name( $selected_traits[$i] );
 954         my $abbr = $c->controller('solGS::Utils')->abbreviate_term($tr);
 955         $traits .= $abbr;
 956         $traits .= "\t" unless ( $i == $#selected_traits );
 957
 958     }
 959
 960     my $name     = "selected_traits_pop_${pop_id}";
 961     my $temp_dir = $c->stash->{solgs_tempfiles_dir};
 962     my $file =
 963       $c->controller('solGS::Files')->create_tempfile( $temp_dir, $name );
 964
 965     write_file( $file, { binmode => ':utf8' }, $traits );
 966     $c->stash->{selected_traits_file} = $file;
 967
 968     $name = "trait_info_${trait_id}_pop_${pop_id}";
 969     my $file2 =
 970       $c->controller('solGS::Files')->create_tempfile( $temp_dir, $name );
 971
 972     $c->stash->{trait_file} = $file2;
 973
 974     my $protocol_id = $c->stash->{genotyping_protocol_id};
 975     my $cached      = $c->controller('solGS::CachedResult')
 976       ->check_single_trial_training_data( $c, $pop_id, $protocol_id );
 977
 978     if ( !$cached ) {
 979         $c->controller('solGS::AsyncJob')
 980           ->get_training_pop_data_query_job_args_file( $c, [$pop_id],
 981             $protocol_id );
 982         $c->stash->{prerequisite_jobs} =
 983           $c->stash->{training_pop_data_query_job_args_file};
 984     }
 985
 986     $c->controller('solGS::AsyncJob')->get_gs_modeling_jobs_args_file($c);
 987     $c->stash->{dependent_jobs} = $c->stash->{gs_modeling_jobs_args_file};
 988     $c->controller('solGS::AsyncJob')->run_async($c);
 989
 990 }
 991
 992 sub all_traits_output : Path('/solgs/traits/all/population') Args() {
 993     my ( $self, $c, $training_pop_id, $tr_txt, $traits_selection_id, $gp,
 994         $protocol_id )
 995       = @_;
 996
 997     $c->controller('solGS::genotypingProtocol')
 998       ->stash_protocol_id( $c, $protocol_id );
 999
1000     my @traits_ids;
1001
1002     if ( $traits_selection_id =~ /^\d+$/ ) {
1003         $c->controller('solGS::Gebvs')
1004           ->get_traits_selection_list( $c, $traits_selection_id );
1005         @traits_ids = @{ $c->stash->{traits_selection_list} }
1006           if $c->stash->{traits_selection_list};
1007     }
1008
1009     if ( $training_pop_id =~ /list/ ) {
1010         $c->stash->{list_id} = $training_pop_id =~ s/list_//r;
1011     }
1012
1013     $c->controller('solGS::Search')
1014       ->project_description( $c, $training_pop_id );
1015     my $training_pop_name = $c->stash->{project_name};
1016     my $training_pop_desc = $c->stash->{project_desc};
1017
1018     my $args = {
1019         'training_pop_id'        => $training_pop_id,
1020         'genotyping_protocol_id' => $protocol_id,
1021         'data_set_type'          => 'single_population'
1022     };
1023
1024     my $training_pop_page =
1025       $c->controller('solGS::Path')->training_page_url($args);
1026     $training_pop_page =
1027       qq | <a href="$training_pop_page">$training_pop_name</a> |;
1028
1029     my @select_analysed_traits;
1030
1031     if ( !@traits_ids ) {
1032         $c->stash->{message} =
1033             "Cached output for this page does not exist anymore.\n"
1034           . " Please go to $training_pop_page and run the analysis.";
1035
1036         $c->stash->{template} = "/generic_message.mas";
1037     }
1038     else {
1039         my @traits_pages;
1040         if ( scalar(@traits_ids) == 1 ) {
1041             my $trait_id = $traits_ids[0];
1042
1043             my $args = {
1044                 'trait_id'               => $trait_id,
1045                 'training_pop_id'        => $training_pop_id,
1046                 'genotyping_protocol_id' => $protocol_id,
1047                 'data_set_type'          => 'single_population'
1048             };
1049
1050             my $model_page =
1051               $c->controller('solGS::Path')->model_page_url($args);
1052             $c->res->redirect($model_page);
1053             $c->detach();
1054         }
1055         else {
1056             foreach my $trait_id (@traits_ids) {
1057                 $c->stash->{trait_id} = $trait_id;
1058                 $c->stash->{model_id} = $training_pop_id;
1059                 $c->controller('solGS::modelAccuracy')
1060                   ->create_model_summary( $c, $training_pop_id, $trait_id );
1061                 my $model_summary = $c->stash->{model_summary};
1062
1063                 push @traits_pages, $model_summary;
1064             }
1065         }
1066
1067         $c->stash->{training_traits_ids} = \@traits_ids;
1068         $c->controller('solGS::Gebvs')->training_pop_analyzed_traits($c);
1069         my $analyzed_traits = $c->stash->{training_pop_analyzed_traits};
1070
1071         $c->stash->{trait_pages} = \@traits_pages;
1072
1073         my @training_pop_data =
1074           ( [ $training_pop_page, $training_pop_desc, \@traits_pages ] );
1075
1076         $c->stash->{model_data}           = \@training_pop_data;
1077         $c->stash->{training_pop_id}      = $training_pop_id;
1078         $c->stash->{training_pop_name}    = $training_pop_name;
1079         $c->stash->{training_pop_desc}    = $training_pop_desc;
1080         $c->stash->{training_pop_url}     = $training_pop_page;
1081         $c->stash->{training_traits_code} = $traits_selection_id;
1082         $c->stash->{analysis_type} =
1083           $c->controller('solGS::Path')->page_type($c);
1084
1085         $c->controller('solGS::Trait')
1086           ->get_acronym_pairs( $c, $training_pop_id );
1087
1088         $c->stash->{template} = '/solgs/population/models/detail.mas';
1089     }
1090
1091 }
1092
1093 sub traits_with_valid_models {
1094     my ( $self, $c ) = @_;
1095
1096     my $pop_id = $c->stash->{pop_id} || $c->stash->{training_pop_id};
1097
1098     $c->controller('solGS::Gebvs')->training_pop_analyzed_traits($c);
1099
1100     my @analyzed_traits = @{ $c->stash->{training_pop_analyzed_traits} };
1101     my @filtered_analyzed_traits;
1102     my @valid_traits_ids;
1103
1104     foreach my $analyzed_trait (@analyzed_traits) {
1105         $c->controller('solGS::modelAccuracy')
1106           ->get_model_accuracy_value( $c, $pop_id, $analyzed_trait );
1107         my $av = $c->stash->{accuracy_value};
1108         if ( $av && $av =~ m/\d+/ && $av > 0 ) {
1109             push @filtered_analyzed_traits, $analyzed_trait;
1110
1111             $c->stash->{trait_abbr} = $analyzed_trait;
1112             $c->controller('solGS::Trait')->get_trait_details_of_trait_abbr($c);
1113             push @valid_traits_ids, $c->stash->{trait_id};
1114         }
1115     }
1116
1117     @filtered_analyzed_traits = uniq(@filtered_analyzed_traits);
1118     @valid_traits_ids         = uniq(@valid_traits_ids);
1119
1120     $c->stash->{traits_with_valid_models}     = \@filtered_analyzed_traits;
1121     $c->stash->{traits_ids_with_valid_models} = \@valid_traits_ids;
1122
1123 }
1124
1125 sub model_pheno_means_type {
1126     my ( $self, $c ) = @_;
1127
1128     $c->controller("solGS::Files")->model_phenodata_file($c);
1129     my $model_pheno_file = $c->{stash}->{model_phenodata_file};
1130
1131     my $mean_type;
1132     if ( -s $model_pheno_file ) {
1133         my @model_data = read_file( $model_pheno_file, { binmode => ':utf8' } );
1134         $mean_type = shift(@model_data);
1135
1136         if ( $mean_type =~ /fixed_effects/ ) {
1137             $mean_type = 'Adjusted means, fixed (genotype) effects model';
1138         }
1139         elsif ( $mean_type =~ /random_effects/ ) {
1140             $mean_type = 'Adjusted means, random (genotype) effects model';
1141         }
1142         else {
1143             if ( $c->req->path =~ /combined\/populations\// ) {
1144                 $mean_type =
1145 'Average of adjusted means and/or arithmetic means across trials.';
1146             }
1147             else {
1148                 $mean_type = 'Arithmetic means';
1149             }
1150         }
1151     }
1152
1153     return $mean_type;
1154
1155 }
1156
1157 #generates descriptive stat for a trait phenotype data
1158 sub model_phenotype_stat {
1159     my ( $self, $c ) = @_;
1160
1161     $c->stash->{model_pheno_means_descriptive_stat} =
1162       $self->model_pheno_means_stat($c);
1163     $c->stash->{model_pheno_raw_descriptive_stat} =
1164       $self->model_pheno_raw_stat($c);
1165
1166 }
1167
1168 sub model_pheno_means_stat {
1169     my ( $self, $c ) = @_;
1170
1171     my $data =
1172       $c->controller('solGS::Histogram')->get_trait_pheno_means_data($c);
1173
1174     my $desc_stat;
1175     if ( $data && !$c->stash->{background_job} ) {
1176         $desc_stat = $self->calc_descriptive_stat($data);
1177     }
1178
1179     my $pheno_type = $self->model_pheno_means_type($c);
1180     $desc_stat = [
1181         [ 'Phenotype means type', $pheno_type ],
1182         [ 'Observation level',    'accession' ],
1183         @$desc_stat
1184     ];
1185
1186     return $desc_stat;
1187
1188 }
1189
1190 sub model_pheno_raw_stat {
1191     my ( $self, $c ) = @_;
1192
1193     my $data = $c->controller("solGS::Histogram")->get_trait_pheno_raw_data($c);
1194     my $desc_stat;
1195
1196     if ($data) {
1197         $desc_stat = $self->calc_descriptive_stat($data);
1198     }
1199
1200     $desc_stat = [ [ 'Observation level', 'plot' ], @$desc_stat ];
1201     return $desc_stat;
1202
1203 }
1204
1205 sub calc_descriptive_stat {
1206     my ( $self, $data ) = @_;
1207
1208     my @clean_data;
1209     foreach (@$data) {
1210         unless ( !$_->[0] ) {
1211             my $d = $_->[1];
1212             chomp($d);
1213
1214             if ( $d =~ /\d+/ ) {
1215                 push @clean_data, $d;
1216             }
1217         }
1218     }
1219
1220     my $stat = Statistics::Descriptive::Full->new();
1221     $stat->add_data(@clean_data);
1222
1223     my $min  = $stat->min;
1224     my $max  = $stat->max;
1225     my $mean = $stat->mean;
1226     my $med  = $stat->median;
1227     my $std  = $stat->standard_deviation;
1228     my $cnt  = scalar(@$data);
1229     my $cv   = ( $std / $mean ) * 100;
1230     my $na   = scalar(@$data) - scalar(@clean_data);
1231
1232     if ( $na == 0 ) { $na = '--'; }
1233
1234     my $round = Math::Round::Var->new(0.01);
1235     $std  = $round->round($std);
1236     $mean = $round->round($mean);
1237     $cv   = $round->round($cv);
1238     $cv   = $cv . '%';
1239
1240     my @desc_stat = (
1241         [ 'Observations count',       $cnt ],
1242         [ 'Missing data',             $na ],
1243         [ 'Minimum',                  $min ],
1244         [ 'Maximum',                  $max ],
1245         [ 'Arithmetic mean',          $mean ],
1246         [ 'Median',                   $med ],
1247         [ 'Standard deviation',       $std ],
1248         [ 'Coefficient of variation', $cv ]
1249     );
1250
1251     return \@desc_stat;
1252
1253 }
1254
1255 sub first_stock_genotype_data {
1256     my ( $self, $c, $pop_id, $protocol_id ) = @_;
1257
1258     $c->stash->{check_data_exists} = 1;
1259     $c->controller('solGS::Files')
1260       ->genotype_file_name( $c, $pop_id, $protocol_id );
1261     my $geno_file = $c->stash->{genotype_file_name};
1262
1263     $c->controller('solGS::Files')
1264       ->first_stock_genotype_file( $c, $pop_id, $protocol_id );
1265     my $f_geno_file = $c->stash->{first_stock_genotype_file};
1266
1267     if ( !-s $geno_file && !-s $f_geno_file ) {
1268         $self->submit_cluster_genotype_query( $c, [$pop_id], $protocol_id );
1269     }
1270 }
1271
1272 sub phenotype_file {
1273     my ( $self, $c, $pop_id ) = @_;
1274
1275     if ( !$pop_id ) {
1276         $pop_id =
1277              $c->stash->{pop_id}
1278           || $c->stash->{training_pop_id}
1279           || $c->stash->{trial_id};
1280     }
1281
1282     $c->stash->{pop_id} = $pop_id;
1283     die "Population id must be provided to get the phenotype data set."
1284       if !$pop_id;
1285     $pop_id =~ s/combined_//;
1286
1287     if ( $c->stash->{list_reference} || $pop_id =~ /list/ ) {
1288         if ( !$c->user ) {
1289
1290             my $page = "/" . $c->req->path;
1291
1292             $c->res->redirect("/solgs/login/message?page=$page");
1293             $c->detach;
1294         }
1295     }
1296
1297     $c->controller('solGS::Files')->phenotype_file_name( $c, $pop_id );
1298     my $pheno_file = $c->stash->{phenotype_file_name};
1299
1300     no warnings 'uninitialized';
1301
1302     unless ( -s $pheno_file ) {
1303         if ( $pop_id !~ /list/ ) {
1304
1305   #my $args = $c->controller('solGS::AsyncJob')->phenotype_trial_query_args($c);
1306             $c->controller('solGS::AsyncJob')
1307               ->submit_cluster_phenotype_query( $c, [$pop_id] );
1308         }
1309     }
1310
1311     $c->controller('solGS::Trait')->get_all_traits( $c, $pop_id );
1312
1313     $c->stash->{phenotype_file} = $pheno_file;
1314
1315 }
1316
1317 sub format_phenotype_dataset {
1318     my ( $self, $data_ref, $metadata, $traits_file ) = @_;
1319
1320     my $data = $$data_ref;
1321     my @rows = split( /\n/, $data );
1322
1323     my $formatted_headers =
1324       $self->format_phenotype_dataset_headers( $rows[0], $metadata,
1325         $traits_file );
1326     $rows[0] = $formatted_headers;
1327
1328     my $formatted_dataset = $self->format_phenotype_dataset_rows( \@rows );
1329
1330     return $formatted_dataset;
1331 }
1332
1333 sub format_phenotype_dataset_rows {
1334     my ( $self, $data_rows ) = @_;
1335
1336     my $data = join( "\n", @$data_rows );
1337
1338     return $data;
1339
1340 }
1341
1342 sub format_phenotype_dataset_headers {
1343     my ( $self, $all_headers, $meta_headers, $traits_file ) = @_;
1344
1345     $all_headers = SGN::Controller::solGS::Utils->clean_traits($all_headers);
1346
1347     my $traits = $all_headers;
1348
1349     foreach my $mh (@$meta_headers) {
1350         $traits =~ s/($mh)//g;
1351     }
1352
1353     write_file( $traits_file, { binmode => ':utf8' }, $traits )
1354       if $traits_file && $traits_file =~ /pop_list/;
1355
1356     my @filtered_traits = split( /\t/, $traits );
1357
1358     my $acronymized_traits =
1359       SGN::Controller::solGS::Utils->acronymize_traits( \@filtered_traits );
1360     my $acronym_table = $acronymized_traits->{acronym_table};
1361
1362     my $formatted_headers;
1363     my @headers = split( "\t", $all_headers );
1364
1365     foreach my $hd (@headers) {
1366         my $acronym;
1367         foreach my $acr ( keys %$acronym_table ) {
1368             $acronym = $acr if $acronym_table->{$acr} =~ /$hd/;
1369             last if $acronym;
1370         }
1371
1372         $formatted_headers .= $acronym ? $acronym : $hd;
1373         $formatted_headers .= "\t" unless ( $headers[-1] eq $hd );
1374     }
1375
1376     return $formatted_headers;
1377
1378 }
1379
1380 sub genotype_file {
1381     my ( $self, $c, $pop_id, $protocol_id ) = @_;
1382
1383     $pop_id = $c->stash->{pop_id} if !$pop_id;
1384
1385     my $training_pop_id  = $c->stash->{training_pop_id};
1386     my $selection_pop_id = $c->stash->{selection_pop_id};
1387
1388     $pop_id = $training_pop_id || $selection_pop_id if !$pop_id;
1389     die "Population id must be provided to get the genotype data set."
1390       if !$pop_id;
1391
1392     if ( $pop_id =~ /list/ ) {
1393         if ( !$c->user ) {
1394             my $path = "/" . $c->req->path;
1395             $c->res->redirect("/solgs/login/message?page=$path");
1396             $c->detach;
1397         }
1398     }
1399
1400     $c->controller('solGS::Files')
1401       ->genotype_file_name( $c, $pop_id, $protocol_id );
1402     my $geno_file = $c->stash->{genotype_file_name};
1403
1404     no warnings 'uninitialized';
1405     unless ( -s $geno_file ) {
1406         my $args = $c->controller('solGS::AsyncJob')
1407           ->genotype_trial_query_args( $c, $pop_id, $protocol_id );
1408         $c->controller('solGS::AsyncJob')
1409           ->submit_cluster_genotype_query( $c, $args, $protocol_id );
1410     }
1411
1412     $c->stash->{genotype_file} = $geno_file;
1413
1414 }
1415
1416 sub get_rrblup_output {
1417     my ( $self, $c ) = @_;
1418
1419     $c->stash->{pop_id} = $c->stash->{combo_pops_id}
1420       if $c->stash->{combo_pops_id};
1421
1422     my $pop_id      = $c->stash->{pop_id} || $c->stash->{training_pop_id};
1423     my $trait_abbr  = $c->stash->{trait_abbr};
1424     my $trait_name  = $c->stash->{trait_name};
1425     my $trait_id    = $c->stash->{trait_id};
1426     my $protocol_id = $c->stash->{genotyping_protocol_id};
1427
1428     my $data_set_type    = $c->stash->{data_set_type};
1429     my $selection_pop_id = $c->stash->{selection_pop_id};
1430
1431     my ( $traits_file, @traits, @trait_pages );
1432
1433     $c->stash->{selection_pop_id} = $selection_pop_id;
1434     if ($trait_id) {
1435         $self->run_rrblup_trait( $c, $trait_id );
1436     }
1437     else {
1438         $traits_file = $c->stash->{selected_traits_file};
1439         my $content = read_file( $traits_file, { binmode => ':utf8' } );
1440
1441         if ( $content =~ /\t/ ) {
1442             @traits = split( /\t/, $content );
1443         }
1444         else {
1445             push @traits, $content;
1446         }
1447
1448         no warnings 'uninitialized';
1449
1450         foreach my $tr (@traits) {
1451             my $acronym_pairs =
1452               $c->controller('solGS::Trait')->get_acronym_pairs($c);
1453             my $trait_name;
1454             if ($acronym_pairs) {
1455                 foreach my $r (@$acronym_pairs) {
1456                     if ( $r->[0] eq $tr ) {
1457                         $trait_name = $r->[1];
1458                         $trait_name =~ s/\n//g;
1459                         $c->stash->{trait_name} = $trait_name;
1460                         $c->stash->{trait_abbr} = $r->[0];
1461                     }
1462                 }
1463             }
1464
1465             my $trait_id = $c->controller('solGS::Search')->model($c)
1466               ->get_trait_id($trait_name);
1467             $self->run_rrblup_trait( $c, $trait_id );
1468
1469             my $args = {
1470                 'trait_id'               => $trait_id,
1471                 'training_pop_id'        => $pop_id,
1472                 'genotyping_protocol_id' => $protocol_id,
1473                 'data_set_type'          => 'single_population'
1474             };
1475
1476             my $model_page =
1477               $c->controller('solGS::Path')->model_page_url($args);
1478
1479             push @trait_pages,
1480               [qq | <a href="$model_page" onclick="solGS.waitPage()">$tr</a>|];
1481         }
1482     }
1483
1484     $c->stash->{combo_pops_analysis_result} = 0;
1485
1486     no warnings 'uninitialized';
1487
1488     if ( $data_set_type !~ /combined_populations/ ) {
1489         if ( scalar(@traits) == 1 ) {
1490             $self->gs_modeling_files($c);
1491             $c->stash->{template} = $c->controller('solGS::Files')
1492               ->template('population/models/model/detail.mas');
1493         }
1494
1495         if ( scalar(@traits) > 1 ) {
1496             $c->stash->{model_id} = $pop_id;
1497             $c->controller('solGS::Gebvs')->training_pop_analyzed_traits($c);
1498             $c->stash->{template} = $c->controller('solGS::Files')
1499               ->template('/population/multiple_traits_output.mas');
1500             $c->stash->{trait_pages} = \@trait_pages;
1501         }
1502     }
1503     else {
1504         $c->stash->{combo_pops_analysis_result} = 1;
1505     }
1506
1507 }
1508
1509 sub run_rrblup_trait {
1510     my ( $self, $c, $trait_id ) = @_;
1511
1512     $trait_id = $c->stash->{trait_id} if !$trait_id;
1513
1514     $c->stash->{trait_id} = $trait_id;
1515     $c->controller('solGS::Trait')->get_trait_details( $c, $trait_id );
1516
1517     my $training_pop_id  = $c->stash->{training_pop_id} || $c->stash->{pop_id};
1518     my $selection_pop_id = $c->stash->{selection_pop_id};
1519
1520     $self->input_files($c);
1521     $self->output_files($c);
1522     $c->stash->{r_script} = 'R/solGS/gs.r';
1523
1524     my $training_pop_gebvs_file  = $c->stash->{rrblup_training_gebvs_file};
1525     my $selection_pop_gebvs_file = $c->stash->{rrblup_selection_gebvs_file};
1526
1527     if ( $training_pop_id && !-s $training_pop_gebvs_file ) {
1528         $c->controller('solGS::AsyncJob')->run_r_script($c);
1529     }
1530     elsif ( ( $selection_pop_id && !-s $selection_pop_gebvs_file ) ) {
1531
1532         $c->controller('solGS::AsyncJob')
1533           ->get_selection_pop_query_args_file($c);
1534         my $pre_req = $c->stash->{selection_pop_query_args_file};
1535
1536         $c->controller('solGS::AsyncJob')->get_gs_modeling_jobs_args_file($c);
1537         my $dependent_job = $c->stash->{gs_modeling_jobs_args_file};
1538
1539         $c->stash->{prerequisite_jobs} = $pre_req;
1540         $c->stash->{dependent_jobs}    = $dependent_job;
1541
1542         $c->controller('solGS::AsyncJob')->run_async($c);
1543     }
1544
1545 }
1546
1547 # sub default :Path {
1548 #     my ( $self, $c ) = @_;
1549 #     $c->forward('search');
1550 # }
1551
1552 =head2 end
1553
1554 Attempt to render a view, if needed.
1555
1556 =cut
1557
1558 #sub render : ActionClass('RenderView') {}
1559 sub begin : Private {
1560     my ( $self, $c ) = @_;
1561
1562     $c->controller('solGS::Files')->get_solgs_dirs($c);
1563
1564 }
1565
1566 =head1 AUTHOR
1567
1568 Isaak Y Tecle <iyt2@cornell.edu>
1569
1570 =head1 LICENSE
1571
1572 This library is free software. You can redistribute it and/or modify
1573 it under the same terms as Perl itself.
1574
1575 =cut
1576
1577 __PACKAGE__->meta->make_immutable;
1578
1579 1;