lib/SGN/Controller/BreedersToolbox/Download.pm

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