lib/SGN/Controller/solGS/Files.pm

   1 package SGN::Controller::solGS::Files;
   2
   3 use Moose;
   4 use namespace::autoclean;
   5
   6 use File::Basename;
   7 use File::Copy;
   8 use File::Path qw / mkpath  /;
   9 use File::Temp qw / tempfile tempdir /;
  10 use File::Spec::Functions qw / catfile catdir/;
  11 use File::Slurp qw /write_file read_file/;
  12 use Cache::File;
  13 use CXGN::People::Person;
  14 use PDF::Create;
  15
  16
  17 BEGIN { extends 'Catalyst::Controller' }
  18
  19
  20 sub marker_effects_file {
  21     my ($self, $c) = @_;
  22
  23     my $pop_id = $c->stash->{pop_id} || $c->stash->{training_pop_id};
  24     my $trait  = $c->stash->{trait_abbr};
  25
  26     my $protocol_id = $c->stash->{genotyping_protocol_id};
  27     my $file_id = "${pop_id}-${trait}-GP-${protocol_id}";
  28
  29     no warnings 'uninitialized';
  30
  31     my $data_set_type = $c->stash->{data_set_type};
  32
  33     my   $cache_data = {key    => 'marker_effects_' . $file_id,
  34                       file      => 'marker_effects_' . $file_id,
  35                       stash_key => 'marker_effects_file',
  36                       cache_dir => $c->stash->{solgs_cache_dir}
  37        };
  38
  39     $self->cache_file($c, $cache_data);
  40
  41 }
  42
  43
  44 sub variance_components_file {
  45     my ($self, $c) = @_;
  46
  47     my $pop_id = $c->stash->{training_pop_id} || $c->stash->{pop_id};
  48     my $trait  = $c->stash->{trait_abbr};
  49
  50     my $data_set_type = $c->stash->{data_set_type};
  51     my $protocol_id = $c->stash->{genotyping_protocol_id};
  52
  53     my $file_id = "${pop_id}-${trait}-GP-${protocol_id}";
  54
  55     no warnings 'uninitialized';
  56
  57
  58     my $cache_data = {key    => 'variance_components_' . $file_id,
  59                       file      => 'variance_components_' . $file_id,
  60                       stash_key => 'variance_components_file',
  61                       cache_dir => $c->stash->{solgs_cache_dir}
  62     };
  63
  64     $self->cache_file($c, $cache_data);
  65 }
  66
  67
  68 sub model_phenodata_file {
  69     my ($self, $c) = @_;
  70
  71     my $pop_id        = $c->stash->{training_pop_id} || $c->stash->{combo_pops_id} ;
  72     my $trait_abbr    = $c->stash->{trait_abbr};
  73     my $protocol_id   = $c->stash->{genotyping_protocol_id};
  74
  75     my $id =   "${pop_id}-${trait_abbr}-GP-${protocol_id}";
  76     if ($trait_abbr)
  77     {
  78         no warnings 'uninitialized';
  79
  80         my $cache_data = {key       => 'model_phenodata_' . $id,
  81                           file      => 'model_phenodata_' .  $id,
  82                           stash_key => 'model_phenodata_file',
  83                           cache_dir => $c->stash->{solgs_cache_dir}
  84         };
  85
  86         $self->cache_file($c, $cache_data);
  87     }
  88 }
  89
  90
  91 sub model_genodata_file {
  92     my ($self, $c) = @_;
  93
  94     my $pop_id        = $c->stash->{training_pop_id} || $c->stash->{combo_pops_id} ;
  95     my $trait_abbr    = $c->stash->{trait_abbr};
  96     my $protocol_id   = $c->stash->{genotyping_protocol_id};
  97
  98     my $id =   "${pop_id}-${trait_abbr}-GP-${protocol_id}";
  99     if ($trait_abbr)
 100     {
 101         no warnings 'uninitialized';
 102
 103         my $cache_data = {key       => 'model_genodata_' . $id,
 104                           file      => 'model_genodata_' .  $id,
 105                           stash_key => 'model_genodata_file',
 106                           cache_dir => $c->stash->{solgs_cache_dir}
 107         };
 108
 109         $self->cache_file($c, $cache_data);
 110     }
 111 }
 112
 113
 114 sub trait_raw_phenodata_file {
 115     my ($self, $c) = @_;
 116
 117     my $pop_id        = $c->stash->{training_pop_id} || $c->stash->{combo_pops_id} ;
 118     my $trait_abbr    = $c->stash->{trait_abbr};
 119
 120     my $id =   "${pop_id}-${trait_abbr}";
 121     if ($trait_abbr)
 122     {
 123         no warnings 'uninitialized';
 124
 125         my $cache_data = {key       => 'trait_raw_phenodata_' . $id,
 126                           file      => 'trait_raw_phenodata_' .  $id,
 127                           stash_key => 'trait_raw_phenodata_file',
 128                           cache_dir => $c->stash->{solgs_cache_dir}
 129         };
 130
 131         $self->cache_file($c, $cache_data);
 132     }
 133 }
 134
 135
 136
 137
 138 sub model_info_file {
 139     my ($self, $c) = @_;
 140
 141     my $pop_id = $c->stash->{training_pop_id} || $c->stash->{combo_pops_id};
 142     my $trait_id = $c->stash->{trait_id};
 143     my $trait_abbr = $c->stash->{trait_abbr};
 144     my $protocol_id = $c->stash->{genotyping_protocol_id};
 145
 146     my $file_id  = "${trait_id}-${pop_id}-GP-${protocol_id}";
 147
 148     my $cache_data = { key       => 'model_info_file_' . $file_id,
 149                        file      => 'model_info_file_' . $file_id,
 150                        stash_key => 'model_info_file',
 151                        cache_dir => $c->stash->{solgs_cache_dir}
 152     };
 153
 154     $self->cache_file($c, $cache_data);
 155 }
 156
 157
 158
 159
 160
 161 sub filtered_training_genotype_file {
 162     my ($self, $c, $pop_id, $protocol_id) = @_;
 163
 164     $pop_id = $c->stash->{training_pop_id} || $c->stash->{pop_id} || $c->{stash}->{combo_pops_id} if !$pop_id;
 165
 166     $protocol_id = $c->stash->{genotyping_protocol_id} if !$protocol_id;
 167     my $file_id = "${pop_id}-GP-${protocol_id}";
 168
 169     my $cache_data = { key       => 'filtered_genotype_data_' . $file_id,
 170                        file      => 'filtered_training_genotype_data_' . $file_id,
 171                        stash_key => 'filtered_training_genotype_file',
 172                        cache_dir => $c->stash->{solgs_cache_dir}
 173     };
 174
 175     $self->cache_file($c, $cache_data);
 176 }
 177
 178 sub genotype_filtering_log_file {
 179     my ($self, $c) = @_;
 180
 181     my $tr_pop_id = $c->stash->{training_pop_id};
 182     my $sel_pop_id = $c->stash->{selection_pop_id};
 183     my $protocol_id = $c->stash->{genotyping_protocol_id};
 184
 185     my $file_id = "${tr_pop_id}";
 186     $file_id .=  "-${sel_pop_id}" if $sel_pop_id;
 187     $file_id .= "-GP-${protocol_id}";
 188
 189     my $cache_data = { key       => 'genotype_filtering_log' . $file_id,
 190                        file      => 'genotype_filtering_log_' . $file_id,
 191                        stash_key => 'genotype_filtering_log_file',
 192                        cache_dir => $c->stash->{solgs_cache_dir}
 193     };
 194
 195     $self->cache_file($c, $cache_data);
 196 }
 197
 198
 199 sub filtered_selection_genotype_file {
 200     my ($self, $c) = @_;
 201
 202     my $tr_pop_id = $c->stash->{training_pop_id};
 203     my $sel_pop_id = $c->stash->{selection_pop_id};
 204     my $protocol_id = $c->stash->{genotyping_protocol_id};
 205     my $file_id = "${tr_pop_id}-${sel_pop_id}-GP-${protocol_id}";
 206
 207     my $cache_data = { key       => 'filtered_genotype_data_' . $file_id,
 208                        file      => 'filtered_selection_genotype_data_' . $file_id,
 209                        stash_key => 'filtered_selection_genotype_file',
 210                        cache_dir => $c->stash->{solgs_cache_dir}
 211     };
 212
 213     $self->cache_file($c, $cache_data);
 214 }
 215
 216
 217 sub formatted_phenotype_file {
 218     my ($self, $c, $pop_id) = @_;
 219
 220     $pop_id = $c->stash->{pop_id} if $pop_id;
 221     $pop_id = $c->{stash}->{combo_pops_id} if !$pop_id;
 222
 223     my $cache_data = { key       => 'formatted_phenotype_data_' . $pop_id,
 224                        file      => 'formatted_phenotype_data_' . $pop_id,
 225                        stash_key => 'formatted_phenotype_file',
 226                        cache_dir => $c->stash->{solgs_cache_dir}
 227     };
 228
 229     $self->cache_file($c, $cache_data);
 230 }
 231
 232
 233 sub phenotype_file_name {
 234     my ($self, $c, $pop_id) = @_;
 235
 236     $pop_id = $c->stash->{training_pop_id} || $c->{stash}->{combo_pops_id} if !$pop_id;
 237
 238     my $dir;
 239     if ($pop_id =~ /list/)
 240     {
 241         $dir = $c->stash->{solgs_lists_dir};
 242     }
 243     elsif ($pop_id =~ /dataset/)
 244     {
 245         $dir = $c->stash->{solgs_datasets_dir};
 246     }
 247     else
 248     {
 249         $dir = $c->stash->{solgs_cache_dir};
 250     }
 251
 252     my $cache_data = { key       => 'phenotype_data_' . $pop_id,
 253                        file      => 'phenotype_data_' . $pop_id,
 254                        stash_key => 'phenotype_file_name',
 255                        cache_dir => $dir
 256     };
 257
 258     $self->cache_file($c, $cache_data);
 259
 260         return $c->stash->{phenotype_file_name};
 261
 262 }
 263
 264
 265 sub analysis_error_file {
 266     my ($self, $c) = @_;
 267
 268     my $type      = $c->stash->{analysis_type};
 269     my $cache_dir = $c->stash->{cache_dir}  || $c->stash->{solgs_cache_dir};
 270     my $file_id   = $c->stash->{file_id};
 271
 272     my $name = "${type}_error_${file_id}";
 273
 274     my $cache_data = { key       => $name,
 275                        file      => $name,
 276                        cache_dir => $cache_dir,
 277                        stash_key => "${type}_error_file",
 278     };
 279
 280     $self->cache_file($c, $cache_data);
 281
 282 }
 283
 284
 285 sub analysis_report_file {
 286     my ($self, $c) = @_;
 287
 288     my $page_type = $c->controller('solGS::Path')->page_type($c, $c->req->referer);
 289     my $analysis_type = $c->stash->{analysis_type}  || $page_type;
 290     $analysis_type =~ s/\s+/_/g;
 291
 292     my $cache_dir = $c->stash->{cache_dir} || $c->stash->{solgs_cache_dir};
 293     my $file_id   = $c->stash->{file_id};
 294
 295     if (!$file_id)
 296     {
 297         my $pop_id = $c->stash->{training_pop_id} || $c->stash->{combo_pops_id};
 298         my $trait_abbr = $c->stash->{trait_abbr};
 299         my $protocol_id = $c->stash->{genotyping_protocol_id};
 300
 301         if ($analysis_type =~ /selection_prediction/)
 302         {
 303             $pop_id .= "_" . $c->stash->{selection_pop_id};
 304         }
 305
 306         $file_id  = "${pop_id}-${trait_abbr}-GP-${protocol_id}";
 307     }
 308
 309     my  $name = "${analysis_type}_report_${file_id}";
 310
 311     my $cache_data = { key       => $name,
 312                        file      => $name,
 313                        cache_dir => $cache_dir,
 314                        stash_key => "${analysis_type}_report_file",
 315     };
 316
 317     $self->cache_file($c, $cache_data);
 318
 319 }
 320
 321
 322 sub genotype_file_name {
 323     my ($self, $c, $pop_id, $protocol_id) = @_;
 324
 325     $protocol_id = $c->stash->{genotyping_protocol_id} if !$protocol_id;
 326
 327     $c->controller('solGS::genotypingProtocol')->stash_protocol_id($c, $protocol_id);
 328     $protocol_id = $c->stash->{genotyping_protocol_id};
 329
 330     my $dir;
 331     if ($pop_id =~ /list/)
 332     {
 333         $dir = $c->stash->{solgs_lists_dir};
 334     }
 335     elsif ($pop_id =~ /dataset/)
 336     {
 337         $dir = $c->stash->{solgs_datasets_dir};
 338     }
 339     else
 340     {
 341         $dir = $c->stash->{solgs_cache_dir};
 342     }
 343
 344     my $file_id = $pop_id . '-GP-' . $protocol_id;
 345
 346     my $cache_data = { key       => 'genotype_data_' . $file_id,
 347                        file      => 'genotype_data_' . $file_id,
 348                        stash_key => 'genotype_file_name',
 349                        cache_dir => $dir
 350     };
 351
 352     $self->cache_file($c, $cache_data);
 353
 354 }
 355
 356
 357 sub relationship_matrix_file {
 358     my ($self, $c) = @_;
 359
 360     my $file_id = $self->kinship_file_id($c);
 361     no warnings 'uninitialized';
 362
 363     my $cache_data = {key    => 'relationship_matrix_table_' . $file_id ,
 364                       file      => 'relationship_matrix_table_' . $file_id,
 365                       stash_key => 'relationship_matrix_table_file',
 366                       cache_dir => $c->stash->{kinship_cache_dir}
 367     };
 368
 369     $self->cache_file($c, $cache_data);
 370
 371    $cache_data = {key    => 'relationship_matrix_json_' . $file_id ,
 372                       file      => 'relationship_matrix_json_' . $file_id,
 373                       stash_key => 'relationship_matrix_json_file',
 374                       cache_dir => $c->stash->{kinship_cache_dir}
 375     };
 376
 377     $self->cache_file($c, $cache_data);
 378
 379 }
 380
 381
 382 sub relationship_matrix_adjusted_file {
 383     my ($self, $c) = @_;
 384
 385     my $file_id = $self->kinship_file_id($c);
 386
 387     my $cache_data = {key    => 'relationship_matrix_adjusted_table_' . $file_id ,
 388                       file      => 'relationship_matrix_adjusted_table_' . $file_id,
 389                       stash_key => 'relationship_matrix_adjusted_table_file',
 390                       cache_dir => $c->stash->{kinship_cache_dir}
 391     };
 392
 393     $self->cache_file($c, $cache_data);
 394
 395     $cache_data = {key    => 'relationship_matrix_adjusted_json_' . $file_id ,
 396                       file      => 'relationship_matrix_adjusted_json_' . $file_id,
 397                       stash_key => 'relationship_matrix_adjusted_json_file',
 398                       cache_dir => $c->stash->{kinship_cache_dir}
 399     };
 400
 401     $self->cache_file($c, $cache_data);
 402
 403 }
 404
 405 sub kinship_file_id {
 406     my ($self, $c) = @_;
 407
 408     my $pop_id = $c->stash->{kinship_pop_id} || $c->stash->{training_pop_id};
 409     my $protocol_id = $c->stash->{genotyping_protocol_id};
 410     my $trait_abbr = $c->stash->{trait_abbr};
 411
 412     my $file_id =  $trait_abbr ?
 413         "${pop_id}_${trait_abbr}_GP_${protocol_id}" :
 414         "${pop_id}_GP_${protocol_id}";
 415
 416     return $file_id;
 417 }
 418
 419 sub average_kinship_file {
 420     my ($self, $c) = @_;
 421
 422     my $file_id = $self->kinship_file_id($c);
 423
 424     my $cache_data = {key    => 'average_kinship_file' . $file_id ,
 425                       file      => 'average_kinship_file_' . $file_id,
 426                       stash_key => 'average_kinship_file',
 427                       cache_dir => $c->stash->{kinship_cache_dir}
 428     };
 429
 430     $self->cache_file($c, $cache_data);
 431
 432 }
 433
 434
 435 sub inbreeding_coefficients_file {
 436     my ($self, $c) = @_;
 437
 438     my $file_id = $self->kinship_file_id($c);
 439
 440     no warnings 'uninitialized';
 441
 442     my $cache_data = {key    => 'inbreeding_coefficients' . $file_id ,
 443                       file      => 'inbreeding_coefficients_' . $file_id,
 444                       stash_key => 'inbreeding_coefficients_file',
 445                       cache_dir => $c->stash->{kinship_cache_dir}
 446     };
 447
 448
 449     $self->cache_file($c, $cache_data);
 450
 451 }
 452
 453
 454 sub validation_file {
 455     my ($self, $c) = @_;
 456
 457     my $pop_id = $c->stash->{training_pop_id} || $c->stash->{pop_id};
 458     my $trait  = $c->stash->{trait_abbr};
 459
 460     my $protocol_id = $c->stash->{genotyping_protocol_id};
 461     my $file_id = $pop_id . '-' . $trait . '-GP-' . $protocol_id;
 462
 463
 464     my $data_set_type = $c->stash->{data_set_type};
 465     no warnings 'uninitialized';
 466
 467
 468     my $cache_data = {
 469         key       => 'cross_validation_' . $file_id,
 470         file      => 'cross_validation_' . $file_id,
 471         stash_key => 'validation_file',
 472         cache_dir => $c->stash->{solgs_cache_dir}
 473     };
 474
 475     $self->cache_file($c, $cache_data);
 476 }
 477
 478
 479 sub combined_gebvs_file {
 480     my ($self, $c, $identifier) = @_;
 481
 482     my $pop_id = $c->stash->{pop_id};
 483
 484     my $cache_data = {
 485         key       => 'selected_traits_gebv_' . $pop_id . '_' . $identifier,
 486         file      => 'selected_traits_gebv_' . $pop_id . '_' . $identifier,
 487         stash_key => 'selected_traits_gebv_file',
 488         cache_dir => $c->stash->{solgs_cache_dir}
 489     };
 490
 491     $self->cache_file($c, $cache_data);
 492
 493 }
 494
 495
 496 sub trait_phenotype_file {
 497     my ($self, $c, $pop_id, $trait) = @_;
 498
 499     my $protocol_id = $c->stash->{genotyping_protocol_id};
 500
 501     my $dir = $c->stash->{solgs_cache_dir};
 502     my $exp = "phenotype_data_${trait}_${pop_id}";
 503     my $file = $self->grep_file($dir, $exp);
 504
 505     $c->stash->{trait_phenotype_file} = $file;
 506
 507 }
 508
 509
 510 sub all_traits_file {
 511     my ($self, $c, $pop_id) = @_;
 512
 513     $pop_id = $c->stash->{pop_id} ||  $c->stash->{training_pop_id} if !$pop_id;
 514
 515     my $cache_data = {key       => 'all_traits_pop' . $pop_id,
 516                       file      => 'all_traits_pop_' . $pop_id,
 517                       stash_key => 'all_traits_file',
 518                       cache_dir => $c->stash->{solgs_cache_dir}
 519     };
 520
 521     $self->cache_file($c, $cache_data);
 522
 523 }
 524
 525
 526 sub traits_list_file {
 527     my ($self, $c, $pop_id) = @_;
 528
 529     $pop_id = $c->stash->{pop_id} || $c->stash->{training_pop_id} if !$pop_id;
 530
 531     my $cache_data = {key       => 'traits_list_pop' . $pop_id,
 532                       file      => 'traits_list_pop_' . $pop_id,
 533                       stash_key => 'traits_list_file',
 534                       cache_dir => $c->stash->{solgs_cache_dir}
 535     };
 536
 537     $self->cache_file($c, $cache_data);
 538
 539 }
 540
 541
 542 sub population_metadata_file {
 543     my ($self, $c, $dir, $file_id) = @_;
 544
 545     my $user_id;
 546     my $owner_id;
 547
 548     if ($c->stash->{list_id})
 549     {
 550         my $list = CXGN::List->new({ dbh => $c->dbc()->dbh(),
 551                                      list_id => $c->stash->{list_id}
 552                                    });
 553
 554         $owner_id = $list->owner;
 555
 556     }
 557     elsif ($c->stash->{dataset_id})
 558     {
 559                $owner_id = $c->controller('solGS::Search')->model($c)->get_dataset_owner($c->stash->{dataset_id});
 560     }
 561
 562     my $person = CXGN::People::Person->new($c->dbc()->dbh(), $owner_id);
 563     $user_id = $person->get_username();
 564
 565     my $cache_data = {key       => "metadata_${user_id}_${file_id}",
 566                       file      => "metadata_${user_id}_${file_id}",
 567                       stash_key => 'population_metadata_file',
 568                       cache_dir => $dir,
 569     };
 570
 571     $self->cache_file($c, $cache_data);
 572
 573 }
 574
 575
 576 sub phenotype_metadata_file {
 577     my ($self, $c) = @_;
 578
 579     my $cache_data = {key       => 'phenotype_metadata',
 580                       file      => 'phenotype_metadata',
 581                       stash_key => 'phenotype_metadata_file',
 582                       cache_dir => $c->stash->{solgs_cache_dir}
 583     };
 584
 585     $self->cache_file($c, $cache_data);
 586
 587 }
 588
 589
 590 sub rrblup_training_gebvs_file {
 591     my ($self, $c, $training_pop_id, $trait_id, $protocol_id) = @_;
 592
 593     my $type = 'training';
 594     my $file_id = $self->gebvs_file_id($c, $type);
 595
 596     my $cache_data = {key       => 'rrblup_training_gebvs_' . $file_id,
 597                       file      => 'rrblup_training_gebvs_' . $file_id,
 598                       stash_key => 'rrblup_training_gebvs_file',
 599                       cache_dir => $c->stash->{solgs_cache_dir}
 600     };
 601
 602     $self->cache_file($c, $cache_data);
 603
 604 }
 605
 606
 607 sub gebvs_file_id {
 608     my ($self, $c, $type) = @_;
 609
 610     my $training_pop_id = $c->stash->{training_pop_id};
 611     my $selection_pop_id = $c->stash->{selection_pop_id};
 612     my $trait_id  = $c->stash->{trait_id};
 613     my $protocol_id = $c->stash->{genotyping_protocol_id};
 614
 615     my $identifier = $training_pop_id;
 616
 617     if ($type =~ /selection/)
 618     {
 619         $identifier = "${identifier}-${selection_pop_id}";
 620     }
 621
 622     $c->controller('solGS::Trait')->get_trait_details($c, $trait_id);
 623     my $trait_abbr  = $c->stash->{trait_abbr};
 624
 625     my $file_id = "${identifier}-${trait_abbr}-GP-${protocol_id}";
 626
 627     return $file_id;
 628 }
 629
 630 sub rrblup_selection_gebvs_file {
 631     my ($self, $c, $training_pop_id, $selection_pop_id, $trait_id, $protocol_id) = @_;
 632
 633     my $type = 'selection';
 634     $c->stash->{selection_pop_id} = $selection_pop_id if $selection_pop_id;
 635     $c->stash->{training_pop_id} = $training_pop_id  if $training_pop_id;
 636
 637     my $file_id = $self->gebvs_file_id($c, $type);
 638
 639     my $cache_data = {key  => 'rrblup_selection_gebvs_' . $file_id,
 640                       file      => 'rrblup_selection_gebvs_' . $file_id,
 641                       stash_key => 'rrblup_selection_gebvs_file',
 642                       cache_dir => $c->stash->{solgs_cache_dir}
 643     };
 644
 645     $self->cache_file($c, $cache_data);
 646
 647 }
 648
 649
 650 sub list_of_prediction_pops_file {
 651     my ($self, $c, $training_pop_id)= @_;
 652
 653     my $protocol_id = $c->stash->{genotyping_protocol_id};
 654     my $file_id = $training_pop_id . '-GP-' . $protocol_id;
 655
 656     my $cache_data = {key       => 'list_of_prediction_pops_' . $file_id,
 657                       file      => 'list_of_prediction_pops_' . $file_id,
 658                       stash_key => 'list_of_prediction_pops_file',
 659                       cache_dir => $c->stash->{solgs_cache_dir}
 660     };
 661
 662     $self->cache_file($c, $cache_data);
 663
 664 }
 665
 666
 667 sub first_stock_genotype_file {
 668     my ($self, $c, $pop_id, $protocol_id) = @_;
 669
 670     $protocol_id = $c->stash->{genotyping_protocol_id} if !$protocol_id;
 671
 672     my $file_id = $pop_id . '-GP-' . $protocol_id;
 673
 674     my $cache_data = {key       => 'first_stock_genotype_file_'. $file_id,
 675                       file      => 'first_stock_genotype_file_' . $file_id,
 676                       stash_key => 'first_stock_genotype_file',
 677                       cache_dir => $c->stash->{solgs_cache_dir}
 678     };
 679
 680     $self->cache_file($c, $cache_data);
 681
 682 }
 683
 684
 685 sub selection_population_file {
 686     my ($self, $c, $selection_pop_id) = @_;
 687
 688     my $tmp_dir = $c->stash->{solgs_tempfiles_dir};
 689
 690     my $file = "selection_population_file_${selection_pop_id}";
 691     my $tempfile = $self->create_tempfile($tmp_dir, $file);
 692
 693     $c->stash->{selection_pop_id}  = $selection_pop_id;
 694     $self->filtered_selection_genotype_file($c);
 695     my $filtered_geno_file = $c->stash->{filtered_selection_genotype_file};
 696
 697     my $geno_files = $filtered_geno_file;
 698
 699     $self->genotype_file_name($c, $selection_pop_id);
 700     $geno_files .= "\t" . $c->stash->{genotype_file_name};
 701
 702     write_file($tempfile, {binmode => ':utf8'}, $geno_files);
 703
 704     $c->stash->{selection_population_file} = $tempfile;
 705
 706 }
 707
 708
 709 sub traits_acronym_file {
 710     my ($self, $c, $pop_id) = @_;
 711
 712     my $cache_data = {key       => 'traits_acronym_pop' . $pop_id,
 713                       file      => 'traits_acronym_pop_' . $pop_id,
 714                       stash_key => 'traits_acronym_file',
 715                       cache_dir => $c->stash->{solgs_cache_dir}
 716     };
 717
 718     $self->cache_file($c, $cache_data);
 719
 720 }
 721
 722
 723 sub template {
 724     my ($self, $file) = @_;
 725
 726     $file =~ s/(^\/)//;
 727     my $dir = '/solgs';
 728
 729     return  catfile($dir, $file);
 730
 731 }
 732
 733
 734 sub cache_file {
 735     my ($self, $c, $cache_data) = @_;
 736
 737     my $cache_dir = $cache_data->{cache_dir} || $c->stash->{cache_dir} ||  $c->stash->{solgs_cache_dir};
 738
 739     my $file_cache  = Cache::File->new(cache_root => $cache_dir,
 740                                        lock_level => Cache::File::LOCK_NFS()
 741         );
 742
 743     $file_cache->purge();
 744
 745     my $file  = $file_cache->get($cache_data->{key});
 746
 747     no warnings 'uninitialized';
 748
 749     unless (-s $file)
 750     {
 751         $file = catfile($cache_dir, $cache_data->{file});
 752
 753          if ($file !~ /(\.\w+)/)
 754         {
 755             my $ext = $cache_data->{ext};
 756             if ($ext)
 757             {
 758                 if ($ext !~ /^\./) { $ext = '.' . $ext}
 759             }
 760             else
 761             {
 762                 $ext = '.txt';
 763             }
 764             $file = $file . $ext;
 765         }
 766         write_file($file, {binmode => ':utf8'});
 767         $file_cache->set($cache_data->{key}, $file, '30 days');
 768     }
 769
 770     $c->stash->{$cache_data->{stash_key}} = $file;
 771
 772 }
 773
 774 sub copy_to_tempfiles_subdir {
 775     my ($self, $c, $file, $dir_name) = @_;
 776
 777     my $tmp_dir      = catfile($c->config->{tempfiles_subdir}, $dir_name);
 778     my $base_tmp_dir = catfile($c->config->{basepath}, $tmp_dir);
 779
 780     mkpath ([$base_tmp_dir], 0, 0755);
 781
 782     $self->copy_file($file, $base_tmp_dir);
 783     $file = catfile($tmp_dir, basename($file));
 784
 785     return $file;
 786
 787 }
 788
 789 sub convert_txt_pdf {
 790     my ($self, $file, $title) = @_;
 791
 792     my $content = read_file($file, {binmode => ':utf8'});
 793     my $pdf_file = $file;
 794     $pdf_file =~ s/txt/pdf/;
 795
 796     my $pdf = PDF::Create->new(
 797         'filename' => $pdf_file,
 798         'Author' => 'solGS M Tool',
 799         'Title' => $title || 'Analysis log',
 800         'CreationDate' => [localtime]
 801     );
 802
 803     my $root = $pdf->new_page('MediaBox' => $pdf->get_page_size('A4'));
 804     my $page = $root->new_page;
 805     my $font = $pdf->font('BaseFont' => 'Courier');
 806
 807     $page->printnl($content, $font);
 808     $pdf->close;
 809
 810     return $pdf_file;
 811
 812 }
 813
 814 sub create_file_id {
 815     my ($self, $c) = @_;
 816
 817     my $training_pop_id  = $c->stash->{training_pop_id};
 818     my $selection_pop_id = $c->stash->{selection_pop_id};
 819     my $data_structure   = $c->stash->{data_structure};
 820     my $list_id          = $c->stash->{list_id};
 821     my $list_type        = $c->stash->{list_type};
 822     my $dataset_id       = $c->stash->{dataset_id};
 823     my $cluster_type     = $c->stash->{cluster_type};
 824     my $combo_pops_id    = $c->stash->{combo_pops_id};
 825     my $data_type        = $c->stash->{data_type};
 826     my $k_number         = $c->stash->{k_number};
 827     my $sindex_name      = $c->stash->{sindex_weigths} || $c->stash->{sindex_name};
 828     my $sel_prop         = $c->stash->{selection_proportion};
 829     my $protocol_id      = $c->stash->{genotyping_protocol_id};
 830     my $cluster_pop_id   = $c->stash->{cluster_pop_id};
 831     my $pca_pop_id   = $c->stash->{pca_pop_id};
 832     my $training_traits_code = $c->stash->{training_traits_code};
 833
 834     $c->controller('solGS::genotypingProtocol')->stash_protocol_id($c, $protocol_id);
 835     $protocol_id = $c->stash->{genotyping_protocol_id};
 836
 837     my $traits_ids = $c->stash->{training_traits_ids};
 838     my @traits_ids =   ref($traits_ids) eq 'ARRAY' ? @{$traits_ids} : ($c->stash->{trait_id});
 839     my $trait_id;
 840
 841     if (scalar(@traits_ids == 1))
 842     {
 843             $trait_id = $traits_ids[0];
 844     }
 845
 846     my $file_id;
 847     my $referer = $c->req->referer;
 848
 849     my $selection_pages = 'solgs\/selection\/'
 850         . '|solgs\/combined\/model\/\d+\/selection\/'
 851         . '|/solgs\/traits\/all\/population\/'
 852         . '|solgs\/models\/combined\/trials\/';
 853
 854
 855     if ($referer =~ /cluster\/analysis\/|\/solgs\/model\/combined\/populations\// && $combo_pops_id)
 856     {
 857             $c->controller('solGS::combinedTrials')->get_combined_pops_list($c, $combo_pops_id);
 858         $c->stash->{pops_ids_list} = $c->stash->{combined_pops_list};
 859             $file_id = $combo_pops_id;
 860             $c->stash->{data_set_type} = 'combined_populations';
 861     }
 862     elsif ($referer =~ /$selection_pages/)
 863     {
 864         if ($selection_pop_id)
 865         {
 866             $file_id =  $selection_pop_id  && $selection_pop_id !~ /^$training_pop_id$/ ?
 867                 $training_pop_id . '-' . $selection_pop_id :
 868                 $training_pop_id;
 869         }
 870         else
 871         {
 872             $file_id =  $cluster_pop_id && $cluster_pop_id != $training_pop_id ?
 873                 $training_pop_id . '-' . $cluster_pop_id :
 874                 $training_pop_id;
 875         }
 876     }
 877     else
 878     {
 879             $file_id = $training_pop_id || $cluster_pop_id || $pca_pop_id;
 880     }
 881
 882     if ($c->req->referer =~ /cluster|pca|kinship/)
 883     {
 884         if ($data_structure =~ /list/)
 885         {
 886         $file_id = "list_${list_id}" if $list_id;
 887         }
 888         elsif ($data_structure =~ /dataset/)
 889         {
 890         $file_id = "dataset_${dataset_id}" if $dataset_id;
 891         }
 892     }
 893
 894     if ($sindex_name)
 895     {
 896         if ($sindex_name ne $selection_pop_id)
 897         {
 898             $file_id .= $sindex_name ? '-' . $sindex_name : "";
 899         }
 900     }
 901
 902     if (!$sindex_name && $training_traits_code)
 903     {
 904         $file_id .= '-traits-' . $training_traits_code;
 905     }
 906
 907     if (!$training_traits_code && $trait_id)
 908     {
 909         $file_id = $file_id . '-' . $trait_id;
 910     }
 911
 912     $file_id = $data_type ? $file_id . '-' . lc($data_type) : $file_id;
 913     if ($cluster_type !~ /hierarchical/i)
 914     {
 915         $file_id = $k_number  ? $file_id . '-k-' . $k_number : $file_id;
 916     }
 917     $file_id = $protocol_id && $data_type =~ /genotype/i ? $file_id . '-gp-' . $protocol_id : $file_id;
 918
 919     if ($sindex_name)
 920     {
 921         $file_id = $sel_prop ? $file_id . '-sp-' . $sel_prop : $file_id;
 922     }
 923
 924     return $file_id;
 925
 926 }
 927
 928
 929 sub format_cluster_output_url {
 930     my ($self, $c, $path) = @_;
 931
 932     my $pop_id = $c->stash->{pop_id};
 933
 934     my $host = $c->req->base;
 935
 936     if ( $host !~ /localhost/)
 937     {
 938         $host =~ s/:\d+//;
 939         $host =~ s/http\w?/https/;
 940     }
 941
 942     my $end = substr($path, -1, 1);
 943     my $front = substr($path, 0, 1);
 944
 945     $path = $path . '/' if $end !~ /\//;
 946     $path =~ s/\///  if $front =~ /\//;
 947
 948     my $output_link = $host . $path . $pop_id;
 949
 950     return $output_link;
 951 }
 952
 953
 954 sub create_tempfile {
 955     my ($self, $dir, $name, $ext) = @_;
 956
 957     $ext = '.' . $ext if $ext;
 958
 959     my ($fh, $file) = tempfile($name . "-XXXXX",
 960                                SUFFIX => $ext,
 961                                DIR => $dir,
 962         );
 963
 964     $fh->close;
 965
 966     return $file;
 967
 968 }
 969
 970
 971 sub copy_file {
 972     my ($self, $file, $dir) = @_;
 973
 974     mkpath($dir, 0, 755);
 975
 976     copy($file, $dir)
 977         or die "could not copy $file to $dir";
 978
 979     return catfile($dir, basename($file));
 980 }
 981
 982
 983 sub grep_file {
 984     my ($self, $dir, $exp) = @_;
 985
 986     opendir my $dh, $dir
 987         or die "can't open $dir: $!\n";
 988
 989     my ($file)  = grep { /^$exp/ && -f "$dir/$_" }  readdir($dh);
 990     close $dh;
 991
 992     if ($file)
 993     {
 994         $file = catfile($dir, $file);
 995     }
 996
 997     return $file;
 998 }
 999
1000
1001 sub get_solgs_dirs {
1002     my ($self, $c) = @_;
1003
1004     my $geno_version    = $c->config->{default_genotyping_protocol};
1005     $geno_version       = 'analysis-data' if ($geno_version =~ /undefined/) || !$geno_version;
1006     $geno_version       =~ s/\s+//g;
1007     my $tmp_dir         = $c->site_cluster_shared_dir;
1008     $tmp_dir            = catdir($tmp_dir, $geno_version);
1009     my $solgs_dir       = catdir($tmp_dir, "solgs");
1010     my $solgs_cache     = catdir($tmp_dir, 'solgs', 'cache');
1011     my $solgs_tempfiles = catdir($tmp_dir, 'solgs', 'tempfiles');
1012     my $solqtl_cache    = catdir($tmp_dir, 'solqtl', 'cache');
1013     my $solqtl_tempfiles = catdir($tmp_dir, 'solqtl', 'tempfiles');
1014     my $solgs_lists     = catdir($tmp_dir, 'solgs', 'tempfiles', 'lists');
1015     my $solgs_datasets  = catdir($tmp_dir, 'solgs', 'tempfiles', 'datasets');
1016     my $histogram_cache = catdir($tmp_dir, 'histogram', 'cache');
1017     my $histogram_temp  = catdir($tmp_dir, 'histogram', 'tempfiles');
1018     my $log_dir         = catdir($tmp_dir, 'log', 'cache');
1019     my $anova_cache     = catdir($tmp_dir, 'anova', 'cache');
1020     my $anova_temp      = catdir($tmp_dir, 'anova', 'tempfiles');
1021     my $corre_cache     = catdir($tmp_dir, 'correlation', 'cache');
1022     my $corre_temp      = catdir($tmp_dir, 'correlation', 'tempfiles');
1023     my $h2_cache        = catdir($tmp_dir, 'heritability', 'cache');
1024     my $h2_temp         = catdir($tmp_dir, 'heritability', 'tempfiles');
1025     my $qc_cache        = catdir($tmp_dir, 'qualityControl', 'cache');
1026     my $qc_temp         = catdir($tmp_dir, 'qualityControl', 'tempfiles');
1027     my $pca_cache       = catdir($tmp_dir, 'pca', 'cache');
1028     my $pca_temp        = catdir($tmp_dir, 'pca', 'tempfiles');
1029     my $cluster_cache   = catdir($tmp_dir, 'cluster', 'cache');
1030     my $cluster_temp    = catdir($tmp_dir, 'cluster', 'tempfiles');
1031     my $sel_index_cache = catdir($tmp_dir, 'selectionIndex', 'cache');
1032     my $sel_index_temp  = catdir($tmp_dir, 'selectionIndex', 'tempfiles');
1033     my $kinship_cache   = catdir($tmp_dir, 'kinship', 'cache');
1034     my $kinship_temp    = catdir($tmp_dir, 'kinship', 'tempfiles');
1035
1036     mkpath (
1037         [
1038          $solgs_dir, $solgs_cache, $solgs_tempfiles, $solgs_lists,  $solgs_datasets,
1039          $pca_cache, $pca_temp, $histogram_cache, $histogram_temp, $log_dir, $corre_cache, $corre_temp,
1040          $h2_temp, $h2_cache,  $qc_cache, $qc_temp, $anova_temp,$anova_cache, $solqtl_cache, $solqtl_tempfiles,
1041          $cluster_cache, $cluster_temp, $sel_index_cache,  $sel_index_temp, $kinship_cache, $kinship_temp
1042         ],
1043         0, 0755
1044         );
1045
1046     $c->stash(solgs_dir                 => $solgs_dir,
1047               solgs_cache_dir           => $solgs_cache,
1048               solgs_tempfiles_dir       => $solgs_tempfiles,
1049               solgs_lists_dir           => $solgs_lists,
1050               solgs_datasets_dir        => $solgs_datasets,
1051               pca_cache_dir             => $pca_cache,
1052               pca_temp_dir              => $pca_temp,
1053               cluster_cache_dir         => $cluster_cache,
1054               cluster_temp_dir          => $cluster_temp,
1055               correlation_cache_dir     => $corre_cache,
1056               correlation_temp_dir      => $corre_temp,
1057               heritability_cache_dir    => $h2_cache,
1058               heritability_temp_dir     => $h2_temp,
1059               qualityControl_cache_dir    => $qc_cache,
1060               qualityControl_temp_dir     => $qc_temp,
1061               histogram_cache_dir       => $histogram_cache,
1062               histogram_temp_dir        => $histogram_temp,
1063               analysis_log_dir          => $log_dir,
1064               anova_cache_dir           => $anova_cache,
1065               anova_temp_dir            => $anova_temp,
1066               solqtl_cache_dir          => $solqtl_cache,
1067               solqtl_tempfiles_dir      => $solqtl_tempfiles,
1068               cache_dir                 => $solgs_cache,
1069               selection_index_cache_dir => $sel_index_cache,
1070               selection_index_temp_dir  => $sel_index_temp,
1071               kinship_cache_dir         => $kinship_cache,
1072               kinship_temp_dir          => $kinship_temp
1073         );
1074
1075 }
1076
1077
1078 ###
1079 1;#
1080 ##