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