lib/SGN/Controller/BreedersToolbox/Download.pm

   1
   2 ###NOTE: This controller points to CXGN::Trial::Download for the phenotype download.
   3
   4 package SGN::Controller::BreedersToolbox::Download;
   5
   6 use Moose;
   7
   8 BEGIN { extends 'Catalyst::Controller'; }
   9
  10 use strict;
  11 use warnings;
  12 use JSON::XS;
  13 use Data::Dumper;
  14 use CGI;
  15 use CXGN::Trial;
  16 use CXGN::Trial::TrialLayout;
  17 use File::Slurp qw | read_file |;
  18 use File::Temp 'tempfile';
  19 use File::Basename;
  20 use File::Copy;
  21 use URI::FromHash 'uri';
  22 use CXGN::List::Transform;
  23 use Spreadsheet::WriteExcel;
  24 use CXGN::Trial::Download;
  25 use POSIX qw(strftime);
  26 use Sort::Maker;
  27 use DateTime;
  28 use SGN::Model::Cvterm;
  29 use CXGN::Trial::TrialLookup;
  30 use CXGN::Location::LocationLookup;
  31 use CXGN::Stock::StockLookup;
  32 use CXGN::Phenotypes::PhenotypeMatrix;
  33 use CXGN::Genotype::Search;
  34 use CXGN::Login;
  35 use CXGN::Stock::StockLookup;
  36
  37 sub breeder_download : Path('/breeders/download/') Args(0) {
  38     my $self = shift;
  39     my $c = shift;
  40
  41     if (!$c->user()) {
  42         # redirect to login page
  43         $c->res->redirect( uri( path => '/solpeople/login.pl', query => { goto_url => $c->req->uri->path_query } ) );
  44         return;
  45     }
  46
  47     $c->stash->{template} = '/breeders_toolbox/download.mas';
  48 }
  49
  50 #Deprecated. Look t0 SGN::Controller::BreedersToolbox::Trial->trial_download
  51 #sub download_trial_layout_action : Path('/breeders/trial/layout/download') Args(1) {
  52 #    my $self = shift;
  53 #    my $c = shift;
  54 #    my $trial_id = shift;
  55 #    my $format = $c->req->param("format");
  56
  57 #    my $trial = CXGN::Trial::TrialLayout -> new({ schema => $c->dbic_schema("Bio::Chado::Schema"), trial_id => $trial_id, experiment_type => 'field_layout' });
  58
  59 #    my $design = $trial->get_design();
  60
  61 #    $self->trial_download_log($c, $trial_id, "trial layout");
  62
  63 #    if ($format eq "csv") {
  64 #       $self->download_layout_csv($c, $trial_id, $design);
  65 #    }
  66 #    else {
  67 #       $self->download_layout_excel($c, $trial_id, $design);
  68 #    }
  69 #}
  70
  71 #Deprecated by deprecation of download_trial_layout_action
  72 #sub download_layout_csv {
  73 #    my $self = shift;
  74 #    my $c = shift;
  75 #    my $trial_id = shift;
  76
  77 #    $c->tempfiles_subdir("downloads"); # make sure the dir exists
  78 #    my ($fh, $tempfile) = $c->tempfile(TEMPLATE=>"download/trial_layout_".$trial_id."_XXXXX");
  79
  80 #    close($fh);
  81
  82 #    my $file_path = $c->config->{basepath}."/".$tempfile.".csv"; # need xls extension to avoid trouble
  83
  84 #    move($tempfile, $file_path);
  85
  86 #    my $td = CXGN::Trial::Download->new(
  87 #       {
  88 #           bcs_schema => $c->dbic_schema("Bio::Chado::Schema"),
  89 #           trial_id => $trial_id,
  90 #           filename => $file_path,
  91 #           format => "TrialLayoutCSV",
  92 #       },
  93 #       );
  94
  95 #    $td->download();
  96 #     my $file_name = basename($file_path);
  97 #     $c->res->content_type('Application/csv');
  98 #     $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
  99
 100 #    my $output = read_file($file_path);
 101
 102 #    $c->res->body($output);
 103 #}
 104
 105 #Deprecated by deprecation of download_trial_layout_action
 106 #sub download_layout_excel {
 107 #    my $self = shift;
 108 #    my $c = shift;
 109 #    my $trial_id = shift;
 110
 111 #    $c->tempfiles_subdir("downloads"); # make sure the dir exists
 112 #    my ($fh, $tempfile) = $c->tempfile(TEMPLATE=>"downloads/trial_layout_".$trial_id."_XXXXX");
 113
 114 #    close($fh);
 115
 116 #    my $file_path = $c->config->{basepath}."/".$tempfile.".xls"; # need xls extension to avoid trouble
 117
 118 #    move($tempfile, $file_path);
 119
 120 #    my $td = CXGN::Trial::Download->new(
 121 #       {
 122 #           bcs_schema => $c->dbic_schema("Bio::Chado::Schema"),
 123 #           trial_id => $trial_id,
 124 #           filename => $file_path,
 125 #           format => "TrialLayoutExcel",
 126 #       },
 127 #       );
 128
 129 #    $td->download();
 130 #      my $file_name = basename($file_path);
 131 #     $c->res->content_type('Application/xls');
 132 #     $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
 133
 134 #    my $output = read_file($file_path);
 135
 136 #    $c->res->body($output);
 137
 138 #}
 139
 140
 141
 142 #sub download_datacollector_excel {
 143 #    my $self = shift;
 144 #    my $c = shift;
 145 #    my $trial_id = shift;
 146
 147 #    $c->tempfiles_subdir("downloads"); # make sure the dir exists
 148 #    my ($fh, $tempfile) = $c->tempfile(TEMPLATE=>"downloads/DataCollector_".$trial_id."_XXXXX");
 149
 150 #    close($fh);
 151
 152 #    my $file_path = $c->config->{basepath}."/".$tempfile.".xls"; # need xls extension to avoid trouble
 153
 154 #    move($tempfile, $file_path);
 155
 156 #    my $td = CXGN::Trial::Download->new(
 157 #       {
 158 #           bcs_schema => $c->dbic_schema("Bio::Chado::Schema"),
 159 #           trial_id => $trial_id,
 160 #           filename => $file_path,
 161 #           format => "DataCollectorExcel",
 162 #       },
 163 #       );
 164
 165 #    $td->download();
 166 #      my $file_name = basename($file_path);
 167 #     $c->res->content_type('Application/xls');
 168 #     $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
 169
 170 #    my $output = read_file($file_path);
 171
 172 #    $c->res->body($output);
 173
 174 #}
 175
 176 sub _parse_list_from_json {
 177     my $list_json = shift;
 178     #print STDERR Dumper $list_json;
 179     my $json = new JSON;
 180     if ($list_json) {
 181         my $decoded_list = $json->allow_nonref->utf8->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode($list_json);
 182         #my $decoded_list = decode_json($list_json);
 183         my @array_of_list_items = @{$decoded_list};
 184         return \@array_of_list_items;
 185     } else {
 186         return;
 187     }
 188 }
 189
 190 #used from wizard page, trial detail page, and manage trials page for downloading phenotypes
 191 sub download_phenotypes_action : Path('/breeders/trials/phenotype/download') Args(0) {
 192     my $self = shift;
 193     my $c = shift;
 194     my $schema = $c->dbic_schema('Bio::Chado::Schema', 'sgn_chado');
 195     my $sgn_session_id = $c->req->param("sgn_session_id");
 196
 197     my $user = $c->user();
 198     if (!$user && !$sgn_session_id) {
 199         $c->res->redirect( uri( path => '/solpeople/login.pl', query => { goto_url => $c->req->uri->path_query } ) );
 200         return;
 201     } elsif (!$user && $sgn_session_id) {
 202         my $login = CXGN::Login->new($schema->storage->dbh);
 203         my $logged_in = $login->query_from_cookie($sgn_session_id);
 204         if (!$logged_in){
 205             $c->res->redirect( uri( path => '/solpeople/login.pl', query => { goto_url => $c->req->uri->path_query } ) );
 206             return;
 207         }
 208     }
 209
 210     my $has_header = defined($c->req->param('has_header')) ? $c->req->param('has_header') : 1;
 211     my $format = $c->req->param("format") && $c->req->param("format") ne 'null' ? $c->req->param("format") : "xls";
 212     my $data_level = $c->req->param("dataLevel") && $c->req->param("dataLevel") ne 'null' ? $c->req->param("dataLevel") : "plot";
 213     my $timestamp_option = $c->req->param("timestamp") && $c->req->param("timestamp") ne 'null' ? $c->req->param("timestamp") : 0;
 214     my $exclude_phenotype_outlier = $c->req->param("exclude_phenotype_outlier") && $c->req->param("exclude_phenotype_outlier") ne 'null' && $c->req->param("exclude_phenotype_outlier") ne 'undefined' ? $c->req->param("exclude_phenotype_outlier") : 0;
 215     my $include_row_and_column_numbers = $c->req->param("include_row_and_column_numbers") && $c->req->param("include_row_and_column_numbers") ne 'null' ? $c->req->param("include_row_and_column_numbers") : 0;
 216     my $trait_list = $c->req->param("trait_list");
 217     my $trait_component_list = $c->req->param("trait_component_list");
 218     my $year_list = $c->req->param("year_list");
 219     my $location_list = $c->req->param("location_list");
 220     my $trial_list = $c->req->param("trial_list");
 221     my $accession_list = $c->req->param("accession_list");
 222     my $plot_list = $c->req->param("plot_list");
 223     my $plant_list = $c->req->param("plant_list");
 224     my $trait_contains = $c->req->param("trait_contains");
 225     my $phenotype_min_value = $c->req->param("phenotype_min_value") && $c->req->param("phenotype_min_value") ne 'null' ? $c->req->param("phenotype_min_value") : "";
 226     my $phenotype_max_value = $c->req->param("phenotype_max_value") && $c->req->param("phenotype_max_value") ne 'null' ? $c->req->param("phenotype_max_value") : "";
 227     my $search_type = $c->req->param("search_type") || 'fast';
 228
 229     my @trait_list;
 230     if ($trait_list && $trait_list ne 'null') { print STDERR "trait_list: ".Dumper $trait_list."\n"; @trait_list = @{_parse_list_from_json($trait_list)}; }
 231     my @trait_component_list;
 232     if ($trait_component_list && $trait_component_list ne 'null') { print STDERR "trait_component_list: ".Dumper $trait_component_list."\n"; @trait_component_list = @{_parse_list_from_json($trait_component_list)}; }
 233     my @trait_contains_list;
 234     if ($trait_contains && $trait_contains ne 'null') { print STDERR "trait_contains: ".Dumper $trait_contains."\n"; @trait_contains_list = @{_parse_list_from_json($trait_contains)}; }
 235     my @year_list;
 236     if ($year_list && $year_list ne 'null') { print STDERR "year list: ".Dumper $year_list."\n"; @year_list = @{_parse_list_from_json($year_list)}; }
 237     my @location_list;
 238     if ($location_list && $location_list ne 'null') { print STDERR "location list: ".Dumper $location_list."\n"; @location_list = @{_parse_list_from_json($location_list)}; }
 239     my @trial_list;
 240     if ($trial_list && $trial_list ne 'null') { print STDERR "trial list: ".Dumper $trial_list."\n"; @trial_list = @{_parse_list_from_json($trial_list)}; }
 241     my @accession_list;
 242     if ($accession_list && $accession_list ne 'null') { print STDERR "accession list: ".Dumper $accession_list."\n";@accession_list = @{_parse_list_from_json($accession_list)}; }
 243     my @plot_list;
 244     if ($plot_list && $plot_list ne 'null') { print STDERR "plot list: ".Dumper $plot_list."\n"; @plot_list = @{_parse_list_from_json($plot_list)}; }
 245     my @plant_list;
 246     if ($plant_list && $plant_list ne 'null') { print STDERR "plant list: ".Dumper $plant_list."\n"; @plant_list = @{_parse_list_from_json($plant_list)}; }
 247
 248     #Input list arguments can be arrays of integer ids or strings; however, when fed to CXGN::Trial::Download, they must be arrayrefs of integer ids
 249     my @trait_list_int;
 250     foreach (@trait_list) {
 251         if ($_ =~ m/^\d+$/) {
 252             push @trait_list_int, $_;
 253         } else {
 254             my $cvterm_id = SGN::Model::Cvterm->get_cvterm_row_from_trait_name($schema, $_)->cvterm_id();
 255             push @trait_list_int, $cvterm_id;
 256         }
 257     }
 258
 259     if (scalar(@trait_component_list)>0){
 260         if ($trait_component_list[0] =~ m/^\d+$/) {
 261             my $trait_cvterm_ids = SGN::Model::Cvterm->get_traits_from_components($schema, \@trait_component_list);
 262             foreach (@$trait_cvterm_ids) {
 263               push @trait_list_int, $_;
 264             }
 265         } else {
 266             my @trait_component_ids;
 267             foreach (@trait_component_list) {
 268                 my $cvterm_id = SGN::Model::Cvterm->get_cvterm_row_from_trait_name($schema, $_)->cvterm_id();
 269                 push @trait_component_ids, $cvterm_id;
 270             }
 271             my $trait_cvterm_ids = SGN::Model::Cvterm->get_traits_from_components($schema, \@trait_component_ids);
 272             foreach (@$trait_cvterm_ids) {
 273               push @trait_list_int, $_;
 274             }
 275         }
 276     }
 277
 278     my @plot_list_int;
 279     foreach (@plot_list) {
 280         if ($_ =~ m/^\d+$/) {
 281             push @plot_list_int, $_;
 282         } else {
 283             my $stock_lookup = CXGN::Stock::StockLookup->new({ schema => $schema, stock_name=>$_ });
 284             my $stock_id = $stock_lookup->get_stock_exact()->stock_id();
 285             push @plot_list_int, $stock_id;
 286         }
 287     }
 288     my @accession_list_int;
 289     foreach (@accession_list) {
 290         if ($_ =~ m/^\d+$/) {
 291             push @accession_list_int, $_;
 292         } else {
 293             my $stock_lookup = CXGN::Stock::StockLookup->new({ schema => $schema, stock_name=>$_ });
 294             my $stock_id = $stock_lookup->get_stock_exact()->stock_id();
 295             push @accession_list_int, $stock_id;
 296         }
 297     }
 298     my @plant_list_int;
 299     foreach (@plant_list) {
 300         if ($_ =~ m/^\d+$/) {
 301             push @plant_list_int, $_;
 302         } else {
 303             my $stock_lookup = CXGN::Stock::StockLookup->new({ schema => $schema, stock_name=>$_ });
 304             my $stock_id = $stock_lookup->get_stock_exact()->stock_id();
 305             push @plant_list_int, $stock_id;
 306         }
 307     }
 308     my @trial_list_int;
 309     foreach (@trial_list) {
 310         if ($_ =~ m/^\d+$/) {
 311             push @trial_list_int, $_;
 312         } else {
 313             my $trial_lookup = CXGN::Trial::TrialLookup->new({ schema => $schema, trial_name=>$_ });
 314             my $trial_id = $trial_lookup->get_trial()->project_id();
 315             push @trial_list_int, $trial_id;
 316         }
 317     }
 318     my @location_list_int;
 319     foreach (@location_list) {
 320         if ($_ =~ m/^\d+$/) {
 321             push @location_list_int, $_;
 322         } else {
 323             my $location_lookup = CXGN::Location::LocationLookup->new({ schema => $schema, location_name=>$_ });
 324             my $location_id = $location_lookup->get_geolocation()->nd_geolocation_id();
 325             push @location_list_int, $location_id;
 326         }
 327     }
 328
 329     my $plugin = "";
 330     if ($format eq "xls") {
 331         $plugin = "TrialPhenotypeExcel";
 332     }
 333     if ($format eq "csv") {
 334         $plugin = "TrialPhenotypeCSV";
 335     }
 336
 337     my $dir = $c->tempfiles_subdir('download');
 338     my $temp_file_name = "phenotype" . "XXXX";
 339     my $rel_file = $c->tempfile( TEMPLATE => "download/$temp_file_name");
 340     $rel_file = $rel_file . ".$format";
 341     my $tempfile = $c->config->{basepath}."/".$rel_file;
 342
 343     print STDERR "TEMPFILE : $tempfile\n";
 344
 345     #List arguments should be arrayrefs of integer ids
 346     my $download = CXGN::Trial::Download->new({
 347         bcs_schema => $schema,
 348         trait_list => \@trait_list_int,
 349         year_list => \@year_list,
 350         location_list => \@location_list_int,
 351         trial_list => \@trial_list_int,
 352         accession_list => \@accession_list_int,
 353         plot_list => \@plot_list_int,
 354         plant_list => \@plant_list_int,
 355         filename => $tempfile,
 356         format => $plugin,
 357         data_level => $data_level,
 358         include_timestamp => $timestamp_option,
 359         include_row_and_column_numbers => $include_row_and_column_numbers,
 360         exclude_phenotype_outlier => $exclude_phenotype_outlier,
 361         trait_contains => \@trait_contains_list,
 362         phenotype_min_value => $phenotype_min_value,
 363         phenotype_max_value => $phenotype_max_value,
 364         search_type=>$search_type,
 365         has_header=>$has_header
 366     });
 367
 368     my $error = $download->download();
 369
 370     my $file_name = "phenotype.$format";
 371     $c->res->content_type('Application/'.$format);
 372     $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
 373
 374     my $output = read_file($tempfile);
 375
 376     $c->res->body($output);
 377 }
 378
 379
 380 #Deprecated. Look to download_phenotypes_action
 381 #sub download_trial_phenotype_action : Path('/breeders/trial/phenotype/download') Args(1) {
 382 #    my $self = shift;
 383 #    my $c = shift;
 384 #    my $trial_id = shift;
 385 #    my $format = $c->req->param("format");
 386
 387 #    my $schema = $c->dbic_schema("Bio::Chado::Schema");
 388 #    my $plugin = "TrialPhenotypeExcel";
 389 #    if ($format eq "csv") { $plugin = "TrialPhenotypeCSV"; }
 390
 391 #    my $t = CXGN::Trial->new( { bcs_schema => $schema, trial_id => $trial_id });
 392
 393 #    $c->tempfiles_subdir("download");
 394 #    my $trial_name = $t->get_name();
 395 #    $trial_name =~ s/ /\_/g;
 396 #    my $location = $t->get_location()->[1];
 397 #    $location =~ s/ /\_/g;
 398 #    my ($fh, $tempfile) = $c->tempfile(TEMPLATE=>"download/trial_".$trial_name."_phenotypes_".$location."_".$trial_id."_XXXXX");
 399
 400 #    close($fh);
 401 #    my $file_path = $c->config->{basepath}."/".$tempfile.".".$format;
 402 #    move($tempfile, $file_path);
 403
 404
 405 #    my $td = CXGN::Trial::Download->new( {
 406 #       bcs_schema => $schema,
 407 #       trial_id => $trial_id,
 408 #       format => $plugin,
 409 #        filename => $file_path,
 410 #       user_id => $c->user->get_object()->get_sp_person_id(),
 411 #       trial_download_logfile => $c->config->{trial_download_logfile},
 412 #    }
 413 #    );
 414
 415 #    $td->download();
 416
 417 #            my $file_name = basename($file_path);
 418
 419 #     $c->res->content_type('Application/'.$format);
 420 #     $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
 421
 422 #    my $output = read_file($file_path);
 423
 424 #    $c->res->body($output);
 425 #}
 426
 427
 428 #used from manage download page for downloading phenotypes.
 429 sub download_action : Path('/breeders/download_action') Args(0) {
 430     my $self = shift;
 431     my $c = shift;
 432
 433     my $accession_list_id = $c->req->param("accession_list_list_select");
 434     my $trial_list_id     = $c->req->param("trial_list_list_select");
 435     my $trait_list_id     = $c->req->param("trait_list_list_select");
 436     my $format            = $c->req->param("format");
 437     my $datalevel         = $c->req->param("phenotype_datalevel");
 438     my $exclude_phenotype_outlier = $c->req->param("exclude_phenotype_outlier") || 0;
 439     my $timestamp_included = $c->req->param("timestamp") || 0;
 440     my $search_type        = $c->req->param("search_type") || 'complete';
 441     my $dl_token = $c->req->param("phenotype_download_token") || "no_token";
 442     my $dl_cookie = "download".$dl_token;
 443     print STDERR "Token is: $dl_token\n";
 444
 445     my $accession_data;
 446     if ($accession_list_id) {
 447         $accession_data = SGN::Controller::AJAX::List->retrieve_list($c, $accession_list_id);
 448     }
 449
 450     my $trial_data;
 451     if ($trial_list_id) {
 452         $trial_data = SGN::Controller::AJAX::List->retrieve_list($c, $trial_list_id);
 453     }
 454
 455     my $trait_data;
 456     if ($trait_list_id) {
 457         $trait_data = SGN::Controller::AJAX::List->retrieve_list($c, $trait_list_id);
 458     }
 459
 460     my @accession_list = map { $_->[1] } @$accession_data;
 461     my @trial_list = map { $_->[1] } @$trial_data;
 462     my @trait_list = map { $_->[1] } @$trait_data;
 463
 464     my $tf = CXGN::List::Transform->new();
 465
 466     my $unique_transform = $tf->can_transform("accession_synonyms", "accession_names");
 467
 468     my $unique_list = $tf->transform($c->dbic_schema("Bio::Chado::Schema"), $unique_transform, \@accession_list);
 469
 470     # get array ref out of hash ref so Transform/Plugins can use it
 471     my %unique_hash = %$unique_list;
 472     my $unique_accessions = $unique_hash{transform};
 473
 474     my $schema = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado");
 475     my $t = CXGN::List::Transform->new();
 476
 477     my $acc_t = $t->can_transform("accessions", "accession_ids");
 478     my $accession_id_data = $t->transform($schema, $acc_t, $unique_accessions);
 479
 480     my $trial_t = $t->can_transform("trials", "trial_ids");
 481     my $trial_id_data = $t->transform($schema, $trial_t, \@trial_list);
 482
 483     my $trait_t = $t->can_transform("traits", "trait_ids");
 484     my $trait_id_data = $t->transform($schema, $trait_t, \@trait_list);
 485
 486     my $result;
 487     my $output = "";
 488
 489     my $factory_type;
 490     if ($search_type eq 'complete'){
 491         $factory_type = 'Native';
 492     }
 493     if ($search_type eq 'fast'){
 494         $factory_type = 'MaterializedView';
 495     }
 496         my $phenotypes_search = CXGN::Phenotypes::PhenotypeMatrix->new(
 497                 bcs_schema=>$schema,
 498                 search_type=>$factory_type,
 499                 trait_list=>$trait_id_data->{transform},
 500                 trial_list=>$trial_id_data->{transform},
 501                 accession_list=>$accession_id_data->{transform},
 502                 include_timestamp=>$timestamp_included,
 503         include_row_and_column_numbers=>1,
 504         exclude_phenotype_outlier=>$exclude_phenotype_outlier,
 505                 data_level=>$datalevel,
 506         );
 507         my @data = $phenotypes_search->get_phenotype_matrix();
 508
 509     if ($format eq "html") { #dump html in browser
 510         $output = "";
 511         my @header = @{$data[0]};
 512         my $num_col = scalar(@header);
 513         for (my $line =0; $line< @data; $line++) {
 514             my @columns = @{$data[$line]};
 515             my $step = 1;
 516             for(my $i=0; $i<$num_col; $i++) {
 517                 if ($columns[$i]) {
 518                     $output .= "\"$columns[$i]\"";
 519                 } else {
 520                     $output .= "\"\"";
 521                 }
 522                 if ($step < $num_col) {
 523                     $output .= ",";
 524                 }
 525                 $step++;
 526             }
 527             $output .= "\n";
 528         }
 529         $c->res->content_type("text/plain");
 530         $c->res->body($output);
 531
 532     } else {
 533         # if xls or csv, create tempfile name and place to save it
 534         my $what = "phenotype_download";
 535         my $time_stamp = strftime "%Y-%m-%dT%H%M%S", localtime();
 536         my $dir = $c->tempfiles_subdir('download');
 537         my $temp_file_name = $time_stamp . "$what" . "XXXX";
 538         my $rel_file = $c->tempfile( TEMPLATE => "download/$temp_file_name");
 539         my $tempfile = $c->config->{basepath}."/".$rel_file;
 540
 541         if ($format eq ".csv") {
 542
 543             #build csv with column names
 544             open(CSV, ">", $tempfile) || die "Can't open file $tempfile\n";
 545                 my @header = @{$data[0]};
 546                 my $num_col = scalar(@header);
 547                 for (my $line =0; $line< @data; $line++) {
 548                     my @columns = @{$data[$line]};
 549                     my $step = 1;
 550                     for(my $i=0; $i<$num_col; $i++) {
 551                         if ($columns[$i]) {
 552                             print CSV "\"$columns[$i]\"";
 553                         } else {
 554                             print CSV "\"\"";
 555                         }
 556                         if ($step < $num_col) {
 557                             print CSV ",";
 558                         }
 559                         $step++;
 560                     }
 561                     print CSV "\n";
 562                 }
 563             close CSV;
 564
 565         } else {
 566             my $ss = Spreadsheet::WriteExcel->new($tempfile);
 567             my $ws = $ss->add_worksheet();
 568
 569             for (my $line =0; $line< @data; $line++) {
 570                 my @columns = @{$data[$line]};
 571                 for(my $col = 0; $col<@columns; $col++) {
 572                     $ws->write($line, $col, $columns[$col]);
 573                 }
 574             }
 575             #$ws->write(0, 0, "$program_name, $location ($year)");
 576             $ss ->close();
 577
 578             $format = ".xls";
 579         }
 580
 581         #Using tempfile and new filename,send file to client
 582         my $file_name = $time_stamp . "$what" . "$format";
 583         $c->res->content_type('Application/'.$format);
 584         $c->res->cookies->{$dl_cookie} = {
 585           value => $dl_token,
 586           expires => '+1m',
 587         };
 588         $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
 589         $output = read_file($tempfile);
 590         $c->res->body($output);
 591     }
 592 }
 593
 594
 595 # pedigree download -- begin
 596
 597 sub download_pedigree_action : Path('/breeders/download_pedigree_action') {
 598     my $self = shift;
 599     my $c = shift;
 600     my $schema = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado");
 601     my $input_format = $c->req->param("input_format") || 'list_id';
 602     my @accession_ids = [];
 603     if ($input_format eq 'accession_ids') {       #use accession ids supplied directly
 604       my $id_string = $c->req->param("ids");
 605       @accession_ids = split(',',$id_string);
 606     }
 607     elsif ($input_format eq 'list_id') {        #get accession names from list and tranform them to ids
 608         my$accession_list_id = $c->req->param("pedigree_accession_list_list_select");
 609         my $accession_data = SGN::Controller::AJAX::List->retrieve_list($c, $accession_list_id);
 610         my @accession_list = map { $_->[1] } @$accession_data;
 611
 612         my $t = CXGN::List::Transform->new();
 613         my $acc_t = $t->can_transform("accessions", "accession_ids");
 614         my $accession_id_hash = $t->transform($schema, $acc_t, \@accession_list);
 615         @accession_ids = @{$accession_id_hash->{transform}};
 616     }
 617
 618     my $ped_format = $c->req->param("ped_format");
 619     my $dl_token = $c->req->param("pedigree_download_token") || "no_token";
 620     my $dl_cookie = "download".$dl_token;
 621     print STDERR "Token is: $dl_token\n";
 622
 623     my ($tempfile, $uri) = $c->tempfile(TEMPLATE => "pedigree_download_XXXXX", UNLINK=> 0);
 624
 625     open my $FILE, '>', $tempfile or die "Cannot open tempfile $tempfile: $!";
 626
 627         print $FILE "Accession\tFemale_Parent\tMale_Parent\tCross_Type\n";
 628     my $pedigrees_found = 0;
 629     my $stock = CXGN::Stock->new ( schema => $schema);
 630     my $pedigree_rows = $stock->get_pedigree_rows(\@accession_ids, $ped_format);
 631
 632     foreach my $row (@$pedigree_rows) {
 633         print $FILE $row;
 634         $pedigrees_found++;
 635     }
 636
 637     unless ($pedigrees_found > 0) {
 638         print $FILE "$pedigrees_found pedigrees found in the database for the accessions searched. \n";
 639     }
 640     close $FILE;
 641
 642     my $filename = "pedigree.txt";
 643
 644     $c->res->content_type("application/text");
 645     $c->res->cookies->{$dl_cookie} = {
 646       value => $dl_token,
 647       expires => '+1m',
 648     };
 649     $c->res->header('Content-Disposition', qq[attachment; filename="$filename"]);
 650     my $output = read_file($tempfile);
 651
 652     $c->res->body($output);
 653 }
 654
 655 # pedigree download -- end
 656
 657 #=pod
 658
 659
 660 #Used from manage download page for downloading gbs from accessions
 661 sub download_gbs_action : Path('/breeders/download_gbs_action') {
 662   my ($self, $c) = @_;
 663
 664   print STDERR "Collecting download parameters ...  ".localtime()."\n";
 665   my $schema = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado");
 666   my $format = $c->req->param("format") || "list_id";
 667   my $dl_token = $c->req->param("gbs_download_token") || "no_token";
 668   my $dl_cookie = "download".$dl_token;
 669
 670   my (@accession_ids, @accession_list, @accession_genotypes, @unsorted_markers, $accession_data, $id_string, $protocol_id, $trial_id_string, @trial_ids);
 671
 672   $trial_id_string = $c->req->param("trial_ids");
 673   if ($trial_id_string){
 674       @trial_ids = split(',', $trial_id_string);
 675   }
 676
 677   if ($format eq 'accession_ids') {       #use protocol id and accession ids supplied directly
 678     $id_string = $c->req->param("ids");
 679     @accession_ids = split(',',$id_string);
 680     $protocol_id = $c->req->param("protocol_id");
 681     if (!$protocol_id){
 682         my $default_genotyping_protocol = $c->config->{default_genotyping_protocol};
 683         $protocol_id = $schema->resultset('NaturalDiversity::NdProtocol')->find({name=>$default_genotyping_protocol})->nd_protocol_id();
 684     }
 685   }
 686   elsif ($format eq 'list_id') {        #get accession names from list and tranform them to ids
 687
 688
 689     my $accession_list_id = $c->req->param("genotype_accession_list_list_select");
 690     $protocol_id = $c->req->param("genotyping_protocol_select");
 691     #$protocol_id = 2;
 692
 693     if ($accession_list_id) {
 694             $accession_data = SGN::Controller::AJAX::List->retrieve_list($c, $accession_list_id);
 695     }
 696
 697     @accession_list = map { $_->[1] } @$accession_data;
 698
 699     my $t = CXGN::List::Transform->new();
 700
 701     my $acc_t = $t->can_transform("accessions", "accession_ids");
 702     my $accession_id_hash = $t->transform($schema, $acc_t, \@accession_list);
 703     @accession_ids = @{$accession_id_hash->{transform}};
 704   }
 705
 706   my ($tempfile, $uri) = $c->tempfile(TEMPLATE => "gt_download_XXXXX", UNLINK=> 0);  #create download file
 707   open my $TEMP, '>', $tempfile or die "Cannot open tempfile $tempfile: $!";
 708
 709   print STDERR "Downloading genotype data ... ".localtime()."\n";
 710
 711   print STDERR "Accession ids= @accession_ids \n";
 712   print STDERR "Protocol id= $protocol_id \n";
 713
 714   my $genotypes_search = CXGN::Genotype::Search->new({
 715       bcs_schema=>$schema,
 716       accession_list=>\@accession_ids,
 717       trial_list=>\@trial_ids,
 718       protocol_id=>$protocol_id
 719   });
 720   my ($total_count, $genotypes) = $genotypes_search->get_genotype_info();
 721
 722   if (scalar(@$genotypes) == 0) {
 723     my $error = "No genotype data was found for Accessions: @accession_list, Trials: $trial_id_string, and protocol with id $protocol_id. You can determine which accessions have been genotyped with a given protocol by using the search wizard.";
 724     $c->res->content_type("application/text");
 725     $c->res->header('Content-Disposition', qq[attachment; filename="Download error details"]);
 726     $c->res->body($error);
 727     return;
 728   }
 729
 730   # find accession synonyms
 731   my $stocklookup = CXGN::Stock::StockLookup->new({ schema => $schema});
 732   my $synonym_hash = $stocklookup->get_stock_synonyms('stock_id', 'accession', \@accession_ids);
 733   my $synonym_string = "";
 734   while( my( $uniquename, $synonym_list ) = each %{$synonym_hash}){
 735       if(scalar(@{$synonym_list})>0){
 736           if(not length($synonym_string)<1){
 737               $synonym_string.=" ";
 738           }
 739           $synonym_string.=$uniquename."=(";
 740           $synonym_string.= (join ", ", @{$synonym_list}).")";
 741       }
 742   }
 743
 744
 745   print $TEMP "# Downloaded from ".$c->config->{project_name}.": ".localtime()."\n"; # print header info
 746   print $TEMP "# Protocol Id=$protocol_id, Accession List: ".join(',',@accession_list).", Accession Ids: $id_string, Trial Ids: $trial_id_string\n";
 747   if (length($synonym_string)>0){
 748       print $TEMP "# Synonyms: ".$synonym_string."\n";
 749   }
 750   print $TEMP "Marker\t";
 751
 752   print STDERR "Decoding genotype data ...".localtime()."\n";
 753
 754   for (my $i=0; $i < scalar(@$genotypes) ; $i++) {       # loop through resultset, printing accession uniquenames as column headers and storing decoded gt strings in array of hashes
 755
 756     my ($name,$batch_id) = split(/\|/, $genotypes->[$i]->{genotypeUniquename});
 757     print $TEMP $genotypes->[$i]->{germplasmName} . "|" . $batch_id . "\t";
 758     push(@accession_genotypes, $genotypes->[$i]->{genotype_hash});
 759   }
 760   @unsorted_markers = keys   %{ $accession_genotypes[0] };
 761   print $TEMP "\n";
 762
 763   #print STDERR "building custom optimiized sort ... ".localtime()."\n";
 764   my $marker_sort = make_sorter(
 765     qw( GRT ),
 766     number => {
 767       # primary subkeys (chrom number) comparison
 768       # ascending numeric comparison
 769       code => '/(\d+)/',
 770       ascending => 1,
 771       unsigned => 1,
 772     },
 773     number => {
 774       # if chrom number is equal
 775       # return secondary subkey (chrom position) comparison
 776       # ascending numeric comparison
 777       code => '/(\d+)$/',
 778       ascending => 1,
 779       unsigned => 1,
 780     },
 781   );
 782   die "make_sorter: $@" unless $marker_sort;
 783
 784   print STDERR "Sorting markers... ".localtime()."\n";
 785   my @markers = $marker_sort->( @unsorted_markers );
 786
 787   print STDERR "Printing sorted markers and scores ... ".localtime()."\n";
 788   for my $j (0 .. $#markers) {
 789     print $TEMP "$markers[$j]\t";
 790
 791     for my $i ( 0 .. $#accession_genotypes ) {
 792       if($i == $#accession_genotypes ) {                              # print last accession genotype value and move onto new line
 793         print $TEMP "$accession_genotypes[$i]{$markers[$j]}\n";
 794       }
 795       elsif (exists($accession_genotypes[$i]{$markers[$j]})) {        # print genotype and tab
 796         print $TEMP "$accession_genotypes[$i]{$markers[$j]}\t";
 797       }
 798     }
 799   }
 800
 801   close $TEMP;
 802   print STDERR "Downloading file ... ".localtime()."\n";
 803
 804   my $filename;
 805   if (scalar(@$genotypes) > 1) { #name file with number of acessions and protocol id
 806     $filename = scalar(@$genotypes) . "genotypes-p" . $protocol_id . ".txt";
 807   }
 808   else { #name file with acesssion name and protocol id if there's just one
 809     $filename = $genotypes->[0]->{germplasmName} . "genotype-p" . $protocol_id . ".txt";
 810   }
 811
 812   $c->res->content_type("application/text");
 813   $c->res->cookies->{$dl_cookie} = {
 814     value => $dl_token,
 815     expires => '+1m',
 816   };
 817   $c->res->header('Content-Disposition', qq[attachment; filename="$filename"]);
 818   my $output = read_file($tempfile);
 819   $c->res->body($output);
 820 }
 821
 822 #=pod
 823
 824 #Used from manage download GBS Genotype QC
 825
 826 #=cut
 827
 828 sub gbs_qc_action : Path('/breeders/gbs_qc_action') Args(0) {
 829     my $self = shift;
 830     my $c = shift;
 831
 832     my $accession_list_id = $c->req->param("genotype_qc_accession_list_list_select");
 833     my $trial_list_id     = $c->req->param("genotype_trial_list_list_select");
 834     my $protocol_id     = $c->req->param("protocol_list2_select");
 835     my $data_type         = $c->req->param("data_type") || "genotype";
 836     my $format            = $c->req->param("format");
 837     my $dl_token = $c->req->param("qc_download_token") || "no_token";
 838     my $dl_cookie = "download".$dl_token;
 839
 840     my $accession_data = SGN::Controller::AJAX::List->retrieve_list($c, $accession_list_id);
 841     my $trial_data = SGN::Controller::AJAX::List->retrieve_list($c, $trial_list_id);
 842
 843     my @accession_list = map { $_->[1] } @$accession_data;
 844     my @trial_list = map { $_->[1] } @$trial_data;
 845
 846     my $schema = $c->dbic_schema("Bio::Chado::Schema", "sgn_chado");
 847     my $t = CXGN::List::Transform->new();
 848
 849
 850     my $acc_t = $t->can_transform("accessions", "accession_ids");
 851     my $accession_id_data = $t->transform($schema, $acc_t, \@accession_list);
 852
 853     my $trial_t = $t->can_transform("trials", "trial_ids");
 854     my $trial_id_data = $t->transform($schema, $trial_t, \@trial_list);
 855
 856     my $data;
 857     my $output = "";
 858
 859     my ($tempfile, $uri) = $c->tempfile(TEMPLATE => "download_XXXXX", UNLINK=> 0);
 860
 861
 862     open my $TEMP, '>', $tempfile or die "Cannot open output_test00.txt: $!";
 863
 864
 865     $tempfile = File::Spec->catfile($tempfile);
 866
 867
 868     if ($data_type eq "genotype") {
 869
 870         print "Download genotype data\n";
 871
 872     my $genotypes_search = CXGN::Genotype::Search->new({
 873         bcs_schema=>$schema,
 874         accession_list=>$accession_id_data->{transform},
 875         trial_list=>$trial_id_data->{transform},
 876         protocol_id=>$protocol_id
 877     });
 878     my ($total_count, $genotypes) = $genotypes_search->get_genotype_info();
 879     my $data = $genotypes;
 880         $output = "";
 881
 882
 883
 884        my @AoH = ();
 885
 886      for (my $i=0; $i < scalar(@$data) ; $i++)
 887      {
 888       my $decoded = $genotypes->[$i]->{genotype_hash};
 889       push(@AoH, $decoded);
 890      }
 891
 892
 893         my @k=();
 894         for my $i ( 0 .. $#AoH ){
 895            @k = keys   %{ $AoH[$i] }
 896         }
 897
 898
 899         for my $j (0 .. $#k){
 900
 901             print $TEMP "$k[$j]\t";
 902             for my $i ( 0 .. $#AoH ) {
 903
 904             if($i == $#AoH ){
 905             print $TEMP "$AoH[$i]{$k[$j]}";
 906             }else{
 907             print $TEMP "$AoH[$i]{$k[$j]}\t";
 908             }
 909
 910             }
 911
 912             print $TEMP "\n";
 913
 914         }
 915     }
 916
 917
 918     my ($tempfile_out, $uri_out) = $c->tempfile(TEMPLATE => "output_XXXXX", UNLINK=> 0);
 919
 920
 921      system("R --slave --args $tempfile $tempfile_out < R/GBS_QC.R");
 922
 923
 924     my $contents = $tempfile_out;
 925
 926     $c->res->content_type("text/plain");
 927     $c->res->cookies->{$dl_cookie} = {
 928       value => $dl_token,
 929       expires => '+1m',
 930     };
 931     $c->res->body($contents);
 932
 933
 934 }
 935
 936 sub trial_download_log {
 937     my $self = shift;
 938     my $c = shift;
 939     my $trial_id = shift;
 940     my $message = shift;
 941     my $now = DateTime->now();
 942
 943     if (! $c->user) {
 944       return;
 945       print STDERR "Can't find user id, skipping download logging\n";
 946     }
 947     if ($c->config->{trial_download_logfile}) {
 948       my $logfile = $c->config->{trial_download_logfile};
 949       open (my $F, ">>", $logfile) || die "Can't open logfile $logfile\n";
 950       print $F join("\t", (
 951             $c->user->get_object->get_username(),
 952             $trial_id,
 953             $message,
 954             $now->year()."-".$now->month()."-".$now->day()." ".$now->hour().":".$now->minute()));
 955       print $F "\n";
 956       close($F);
 957       print STDERR "Download logged in $logfile\n";
 958     }
 959     else {
 960       print STDERR "Note: set config variable trial_download_logfile to obtain a log of downloaded trials.\n";
 961     }
 962 }
 963
 964
 965 sub download_sequencing_facility_spreadsheet : Path( '/breeders/genotyping/spreadsheet') Args(1) {
 966     my $self = shift;
 967     my $c = shift;
 968     my $trial_id = shift;
 969
 970     my $schema = $c->dbic_schema("Bio::Chado::Schema");
 971     my $t = CXGN::Trial->new( { bcs_schema => $schema, trial_id => $trial_id });
 972
 973     #my $layout = $t->get_layout()->get_design();
 974
 975     $c->tempfiles_subdir("data_export"); # make sure the dir exists
 976     my ($fh, $tempfile) = $c->tempfile(TEMPLATE=>"data_export/trial_".$trial_id."_XXXXX");
 977
 978     my $file_path = $c->config->{basepath}."/".$tempfile.".xls";
 979     move($tempfile, $file_path);
 980
 981     my $td = CXGN::Trial::Download->new( {
 982         bcs_schema => $schema,
 983         trial_id => $trial_id,
 984         format => "IGDFacilitySpreadsheet",
 985         filename => $file_path,
 986         user_id => $c->user->get_object()->get_sp_person_id(),
 987         trial_download_logfile => $c->config->{trial_download_logfile},
 988     }
 989     );
 990
 991     $td->download();
 992
 993
 994     # my $ss = Spreadsheet::WriteExcel->new($c->config->{basepath}."/".$file_path);
 995     # my $ws = $ss->add_worksheet();
 996
 997     # # write primary headers
 998     # #
 999     # $ws->write(0, 0, "Project Details");
1000     # $ws->write(0, 2, "Sample Details");
1001     # $ws->write(0, 12, "Organism Details");
1002     # $ws->write(0, 21, "Origin Details");
1003
1004     # # write secondary headers
1005     # #
1006     # my @headers = (
1007     #   "Project Name",
1008     #   "User ID",
1009     #   "Plate Name",
1010     #   "Well",
1011     #   "Sample Name",
1012     #   "Pedigree",
1013     #   "Population",
1014     #   "Stock Number",
1015     #   "Sample DNA Concentration (ng/ul)",
1016     #   "Sample Volume (ul)",
1017     #   "Sample DNA Mass(ng)",
1018     #   "Kingdom",
1019     #   "Genus",
1020     #   "Species",
1021     #   "Common Name",
1022     #   "Subspecies",
1023     #   "Variety",
1024     #   "Seed Lot"
1025     #   );
1026
1027     # for(my $i=0; $i<@headers; $i++) {
1028     #   $ws->write(1, $i, $headers[$i]);
1029     # }
1030
1031     # # replace accession names with igd_synonyms
1032     # #
1033     # print STDERR "Converting accession names to igd_synonyms...\n";
1034     # foreach my $k (sort wellsort (keys %{$layout})) {
1035     #   my $q = "SELECT value FROM stock JOIN stockprop using(stock_id) JOIN cvterm ON (stockprop.type_id=cvterm.cvterm_id) WHERE cvterm.name='igd_synonym' AND stock.uniquename = ?";
1036     #   my $h = $c->dbc->dbh()->prepare($q);
1037     #   $h->execute($layout->{$k}->{accession_name});
1038     #   my ($igd_synonym) = $h->fetchrow_array();
1039     #   $layout->{$k}->{igd_synonym} = $igd_synonym;
1040     #   if ($layout->{$k}->{accession_name}=~/BLANK/i) {
1041     #       $layout->{$k}->{igd_synonym} = "BLANK";
1042     #   }
1043     # }
1044     # # write plate info
1045     # #
1046     # my $line = 0;
1047
1048     # foreach my $k (sort wellsort (keys %{$layout})) {
1049     #   $ws->write(2 + $line, 0, "NextGen Cassava");
1050     #   my $breeding_program_data = $t->get_breeding_programs();
1051     #   my $breeding_program_name = "";
1052     #   if ($breeding_program_data->[0]) {
1053     #       $breeding_program_name = $breeding_program_data->[0]->[1];
1054     #   }
1055     #   $ws->write(2 + $line, 0, $layout->{$k}->{genotyping_project_name});
1056     #   $ws->write(2 + $line, 1, $layout->{$k}->{genotyping_user_id});
1057     #   $ws->write(2 + $line, 2, $t->get_name());
1058     #   $ws->write(2 + $line, 3, $k);
1059     #   $ws->write(2 + $line, 4, $layout->{$k}->{igd_synonym});
1060     #   $ws->write(2 + $line, 16, "Manihot");
1061     #   $ws->write(2 + $line, 17, "esculenta");
1062     #   $ws->write(2 + $line, 20, $t->get_location());
1063     #   $line++;
1064     # }
1065
1066     # $ss ->close();
1067
1068     # prepare file for download
1069     #
1070     my $file_name = basename($file_path);
1071     $c->res->content_type('Application/xls');
1072     $c->res->header('Content-Disposition', qq[attachment; filename="$file_name"]);
1073
1074
1075
1076     my $output = read_file($file_path, binmode=>':raw');
1077
1078     close($fh);
1079     $c->res->body($output);
1080 }
1081
1082 sub wellsort {
1083     my $row_a = substr($a, 0, 1);
1084     my $row_b = substr($b, 0, 1);
1085
1086     my $col_a;
1087     my $col_b;
1088     if ($a =~ m/(\d+)/) {
1089         $col_a = $1;
1090     }
1091     if ($b =~ m/(\d+)/) {
1092         $col_b = $1;
1093     }
1094
1095     if ($row_a ne $row_b) {
1096         return $row_a cmp $row_b;
1097     }
1098     else {
1099         return $col_a <=> $col_b;
1100     }
1101 }
1102
1103 #=pod
1104 1;