lib/SGN/Controller/AJAX/BreedersToolbox.pm

   1
   2 package SGN::Controller::AJAX::BreedersToolbox;
   3
   4 use Moose;
   5
   6 use URI::FromHash 'uri';
   7 use Data::Dumper;
   8 use File::Slurp "read_file";
   9
  10 use CXGN::List;
  11 use CXGN::BreedersToolbox::Projects;
  12 use CXGN::BreedersToolbox::Delete;
  13 use CXGN::Trial::TrialDesign;
  14 use CXGN::Trial::TrialCreate;
  15 use CXGN::Stock::StockLookup;
  16 use Try::Tiny;
  17
  18 BEGIN { extends 'Catalyst::Controller::REST' }
  19
  20 __PACKAGE__->config(
  21     default   => 'application/json',
  22     stash_key => 'rest',
  23     map       => { 'application/json' => 'JSON', 'text/html' => 'JSON' },
  24    );
  25
  26 sub insert_new_project : Path("/ajax/breeders/project/insert") Args(0) {
  27     my $self = shift;
  28     my $c = shift;
  29
  30     if (! $c->user()) {
  31         $c->stash->{rest} = { error => "You must be logged in to add projects." } ;
  32         return;
  33     }
  34
  35     my $params = $c->req->parameters();
  36
  37     my $schema = $c->dbic_schema('Bio::Chado::Schema');
  38
  39     my $exists = $schema->resultset('Project::Project')->search(
  40         { name => $params->{project_name} }
  41         );
  42
  43     if ($exists > 0) {
  44         $c->stash->{rest} = { error => "This trial name is already used." };
  45         return;
  46     }
  47
  48
  49     my $project = $schema->resultset('Project::Project')->find_or_create(
  50         {
  51             name => $params->{project_name},
  52             description => $params->{project_description},
  53         }
  54         );
  55
  56     my $projectprop_year = $project->create_projectprops( { 'project year' => $params->{year},}, {autocreate=>1}); #cv_name => 'project_property' } );
  57
  58
  59
  60     $c->stash->{rest} = { error => '' };
  61 }
  62
  63 sub get_all_locations :Path("/ajax/breeders/location/all") Args(0) {
  64     my $self = shift;
  65     my $c = shift;
  66
  67     my $bp = CXGN::BreedersToolbox::Projects->new( { schema => $c->dbic_schema("Bio::Chado::Schema") });
  68
  69     my $all_locations = $bp->get_all_locations();
  70
  71     $c->stash->{rest} = { locations => $all_locations };
  72
  73 }
  74
  75 sub insert_new_location :Path("/ajax/breeders/location/insert") Args(0) {
  76     my $self = shift;
  77     my $c = shift;
  78
  79     my $params = $c->request->parameters();
  80
  81     my $description = $params->{description};
  82     my $longitude   = $params->{longitude};
  83     my $latitude    = $params->{latitude};
  84     my $altitude    = $params->{altitude};
  85
  86     if (! $c->user()) { # redirect
  87         $c->stash->{rest} = { error => 'You must be logged in to add a location.' };
  88         return;
  89     }
  90
  91     if (! $c->user->check_roles("submitter") && !$c->user->check_roles("curator")) {
  92         $c->stash->{rest} = { error => 'You do not have the necessary privileges to add locations.' };
  93         return;
  94     }
  95     my $schema = $c->dbic_schema('Bio::Chado::Schema');
  96
  97     my $exists = $schema->resultset('NaturalDiversity::NdGeolocation')->search( { description => $description } )->count();
  98
  99     if ($exists > 0) {
 100         $c->stash->{rest} = { error => "The location - $description - already exists. Please choose another name." };
 101         return;
 102     }
 103
 104     if ( ($longitude && $longitude !~ /^-?[0-9.]+$/) || ($latitude && $latitude !~ /^-?[0-9.]+$/) || ($altitude && $altitude !~ /^[0-9.]+$/) ) {
 105         $c->stash->{rest} = { error => "Longitude, latitude and altitude must be numbers." };
 106         return;
 107     }
 108
 109     my $new_row;
 110     $new_row = $schema->resultset('NaturalDiversity::NdGeolocation')
 111       ->new({
 112              description => $description,
 113             });
 114     if ($longitude) {
 115       $new_row->longitude($longitude);
 116     }
 117     if ($latitude) {
 118       $new_row->latitude($latitude);
 119     }
 120     if ($altitude) {
 121       $new_row->altitude($altitude);
 122     }
 123     $new_row->insert();
 124     $c->stash->{rest} = { success => 1, error => '' };
 125 }
 126
 127 sub delete_location :Path('/ajax/breeders/location/delete') Args(1) {
 128     my $self = shift;
 129     my $c = shift;
 130     my $location_id = shift;
 131
 132     if (!$c->user) {  # require login
 133         $c->stash->{rest} = { error => "You need to be logged in to delete a location." };
 134         return;
 135     }
 136     # require curator or submitter roles
 137     if (! ($c->user->check_roles('curator') || $c->user->check_roles('submitter'))) {
 138         $c->stash->{rest} = { error => "You don't have the privileges to delete a location." };
 139         return;
 140     }
 141     my $del = CXGN::BreedersToolbox::Delete->new( { bcs_schema => $c->dbic_schema("Bio::Chado::Schema") } );
 142     if ($del->can_delete_location($location_id)) {
 143         my $success = $del->delete_location($location_id);
 144
 145         if ($success) {
 146             $c->stash->{rest} = { success => 1 };
 147         }
 148         else {
 149             $c->stash->{rest} = { error => "Could not delete location $location_id" };
 150         }
 151     }
 152     else {
 153         $c->stash->{rest} = { error => "This location cannot be deleted because it has associated data." }
 154     }
 155
 156 }
 157
 158 sub get_breeding_programs : Path('/ajax/breeders/all_programs') Args(0) {
 159     my $self = shift;
 160     my $c = shift;
 161
 162     my $po = CXGN::BreedersToolbox::Projects->new( { schema => $c->dbic_schema("Bio::Chado::Schema") });
 163
 164     my $breeding_programs = $po->get_breeding_programs();
 165
 166     $c->stash->{rest} = $breeding_programs;
 167 }
 168
 169 sub new_breeding_program :Path('/breeders/program/new') Args(0) {
 170     my $self = shift;
 171     my $c = shift;
 172     my $name = $c->req->param("name");
 173     my $desc = $c->req->param("desc");
 174
 175     if (!($c->user() || $c->user()->check_roles('submitter'))) {
 176         $c->stash->{rest} = { error => 'You need to be logged in and have sufficient privileges to add a breeding program.' };
 177     }
 178
 179
 180     my $p = CXGN::BreedersToolbox::Projects->new( { schema => $c->dbic_schema("Bio::Chado::Schema") });
 181
 182     my $error = $p->new_breeding_program($name, $desc);
 183
 184     if ($error) {
 185         $c->stash->{rest} = { error => $error };
 186     }
 187     else {
 188         $c->stash->{rest} =  {};
 189     }
 190
 191 }
 192
 193 sub delete_breeding_program :Path('/breeders/program/delete') Args(1) {
 194     my $self = shift;
 195     my $c = shift;
 196     my $program_id = shift;
 197
 198     if ($c->user && ($c->user->check_roles("curator"))) {
 199         my $p = CXGN::BreedersToolbox::Projects->new( { schema => $c->dbic_schema("Bio::Chado::Schema") });
 200         $p->delete_breeding_program($program_id);
 201         $c->stash->{rest} = [ 1 ];
 202     }
 203     else {
 204         $c->stash->{rest} = { error => "You don't have sufficient privileges to delete breeding programs." };
 205     }
 206 }
 207
 208
 209 sub get_breeding_programs_by_trial :Path('/breeders/programs_by_trial/') Args(1) {
 210     my $self = shift;
 211     my $c = shift;
 212     my $trial_id = shift;
 213
 214     my $p = CXGN::BreedersToolbox::Projects->new( { schema => $c->dbic_schema("Bio::Chado::Schema") } );
 215
 216     my $projects = $p->get_breeding_programs_by_trial($trial_id);
 217
 218     $c->stash->{rest} =   { projects => $projects };
 219
 220 }
 221
 222 sub add_data_agreement :Path('/breeders/trial/add/data_agreement') Args(0) {
 223     my $self = shift;
 224     my $c = shift;
 225
 226     my $project_id = $c->req->param('project_id');
 227     my $data_agreement = $c->req->param('text');
 228
 229     if (!$c->user()) {
 230         $c->stash->{rest} = { error => 'You need to be logged in to add a data agreement' };
 231         return;
 232     }
 233
 234     if (!($c->user()->check_roles('curator') || $c->user()->check_roles('submitter'))) {
 235         $c->stash->{rest} = { error => 'You do not have the required privileges to add a data agreement to this trial.' };
 236         return;
 237     }
 238
 239     my $schema = $c->dbic_schema('Bio::Chado::Schema');
 240
 241     my $data_agreement_cvterm_id_rs = $schema->resultset('Cv::Cvterm')->search( { name => 'data_agreement' });
 242
 243     my $type_id;
 244     if ($data_agreement_cvterm_id_rs->count>0) {
 245         $type_id = $data_agreement_cvterm_id_rs->first()->cvterm_id();
 246     }
 247
 248     eval {
 249         my $project_rs = $schema->resultset('Project::Project')->search(
 250             { project_id => $project_id }
 251             );
 252
 253         if ($project_rs->count() == 0) {
 254             $c->stash->{rest} = { error => "No such project $project_id", };
 255             return;
 256         }
 257
 258         my $project = $project_rs->first();
 259
 260         my $projectprop_rs = $schema->resultset("Project::Projectprop")->search( { 'project_id' => $project_id, 'type_id'=>$type_id });
 261
 262         my $projectprop;
 263         if ($projectprop_rs->count() > 0) {
 264             $projectprop = $projectprop_rs->first();
 265             $projectprop->value($data_agreement);
 266             $projectprop->update();
 267             $c->stash->{rest} = { message => 'Updated data agreement.' };
 268         }
 269         else {
 270             $projectprop = $project->create_projectprops( { 'data_agreement' => $data_agreement,}, {autocreate=>1});
 271             $c->stash->{rest} = { message => 'Inserted new data agreement.'};
 272         }
 273     };
 274     if ($@) {
 275         $c->stash->{rest} = { error => $@ };
 276         return;
 277     }
 278 }
 279
 280 sub get_data_agreement :Path('/breeders/trial/data_agreement/get') :Args(0) {
 281     my $self = shift;
 282     my $c = shift;
 283
 284     my $project_id = $c->req->param('project_id');
 285
 286     my $schema = $c->dbic_schema('Bio::Chado::Schema');
 287
 288     my $data_agreement_cvterm_id_rs = $schema->resultset('Cv::Cvterm')->search( { name => 'data_agreement' });
 289
 290     if ($data_agreement_cvterm_id_rs->count() == 0) {
 291         $c->stash->{rest} = { error => "No data agreements have been added yet." };
 292         return;
 293     }
 294
 295     my $type_id = $data_agreement_cvterm_id_rs->first()->cvterm_id();
 296
 297     print STDERR "PROJECTID: $project_id TYPE_ID: $type_id\n";
 298
 299     my $projectprop_rs = $schema->resultset('Project::Projectprop')->search(
 300         { project_id => $project_id, type_id=>$type_id }
 301         );
 302
 303     if ($projectprop_rs->count() == 0) {
 304         $c->stash->{rest} = { error => "No such project $project_id", };
 305         return;
 306     }
 307     my $projectprop = $projectprop_rs->first();
 308     $c->stash->{rest} = { prop_id => $projectprop->projectprop_id(), text => $projectprop->value() };
 309
 310 }
 311
 312 sub get_all_years : Path('/ajax/breeders/trial/all_years' ) Args(0) {
 313     my $self = shift;
 314     my $c = shift;
 315
 316     my $bp = CXGN::BreedersToolbox::Projects->new({ schema => $c->dbic_schema("Bio::Chado::Schema") });
 317     my @years = $bp->get_all_years();
 318
 319     $c->stash->{rest} = { years => \@years };
 320 }
 321
 322 sub get_trial_location : Path('/ajax/breeders/trial/location') Args(1) {
 323     my $self = shift;
 324     my $c = shift;
 325     my $trial_id = shift;
 326
 327     my $t = CXGN::Trial->new(
 328         {
 329             bcs_schema => $c->dbic_schema("Bio::Chado::Schema"),
 330             trial_id => $trial_id
 331         });
 332
 333     if ($t) {
 334         $c->stash->{rest} = { location => $t->get_location() };
 335     }
 336     else {
 337         $c->stash->{rest} = { error => "The trial with id $trial_id does not exist" };
 338
 339     }
 340 }
 341
 342 sub get_trial_type : Path('/ajax/breeders/trial/type') Args(1) {
 343     my $self = shift;
 344     my $c = shift;
 345     my $trial_id = shift;
 346
 347     my $t = CXGN::Trial->new(
 348         {
 349             bcs_schema => $c->dbic_schema("Bio::Chado::Schema"),
 350             trial_id => $trial_id
 351         });
 352
 353     my $type = $t->get_project_type();
 354     $c->stash->{rest} = { type => $type };
 355 }
 356
 357 sub get_all_trial_types : Path('/ajax/breeders/trial/alltypes') Args(0) {
 358     my $self = shift;
 359     my $c = shift;
 360
 361     my @types = CXGN::Trial::get_all_project_types($c->dbic_schema("Bio::Chado::Schema"));
 362
 363     $c->stash->{rest} = { types => \@types };
 364 }
 365
 366 sub genotype_trial : Path('/ajax/breeders/genotypetrial') Args(0) {
 367     my $self = shift;
 368     my $c = shift;
 369
 370
 371     if (!($c->user()->check_roles('curator') || $c->user()->check_roles('submitter'))) {
 372         $c->stash->{rest} = { error => 'You do not have the required privileges to create a genotyping trial.' };
 373         return;
 374     }
 375
 376     my $list_id = $c->req->param("list_id");
 377     my $name = $c->req->param("name");
 378     my $breeding_program_id = $c->req->param("breeding_program");
 379     my $description = $c->req->param("description");
 380     my $location_id = $c->req->param("location");
 381     my $year = $c->req->param("year");
 382
 383     my $list = CXGN::List->new( { dbh => $c->dbc->dbh(), list_id => $list_id });
 384     my $elements = $list->elements();
 385
 386     if (!$name || !$list_id || !$breeding_program_id || !$location_id || !$year) {
 387         $c->stash->{rest} = { error => "Please provide all parameters." };
 388         return;
 389     }
 390
 391     my $td = CXGN::Trial::TrialDesign->new( { schema => $c->dbic_schema("Bio::Chado::Schema") });
 392
 393     $td->set_stock_list($elements);
 394
 395     $td->set_block_size(96);
 396
 397     $td->set_design_type("genotyping_plate");
 398     $td->set_trial_name($name);
 399     my $design;
 400
 401     eval {
 402         $td->calculate_design();
 403     };
 404
 405     if ($@) {
 406         $c->stash->{rest} = { error => "Design failed. Error: $@" };
 407         return;
 408     }
 409
 410     $design = $td->get_design();
 411
 412     if (exists($design->{error})) {
 413         $c->stash->{rest} = $design;
 414         return;
 415     }
 416     #print STDERR Dumper($design);
 417
 418     my $schema = $c->dbic_schema("Bio::Chado::Schema");
 419     my $location = $schema->resultset("NaturalDiversity::NdGeolocation")->find( { nd_geolocation_id => $location_id } );
 420     if (!$location) {
 421         $c->stash->{rest} = { error => "Unknown location" };
 422         return;
 423     }
 424
 425     my $breeding_program = $schema->resultset("Project::Project")->find( { project_id => $breeding_program_id });
 426     if (!$breeding_program) {
 427         $c->stash->{rest} = { error => "Unknown breeding program" };
 428         return;
 429     }
 430
 431
 432     my $ct = CXGN::Trial::TrialCreate->new( {
 433         chado_schema => $c->dbic_schema("Bio::Chado::Schema"),
 434         phenome_schema => $c->dbic_schema("CXGN::Phenome::Schema"),
 435         metadata_schema => $c->dbic_schema("CXGN::Metadata::Schema"),
 436         dbh => $c->dbc->dbh(),
 437         user_name => $c->user()->get_object()->get_username(),
 438         trial_year => $year,
 439         trial_location => $location->description(),
 440         program => $breeding_program->name(),
 441         trial_description => $description,
 442         design_type => 'genotyping_plate',
 443         design => $design,
 444         trial_name => $name,
 445         is_genotyping => 1,
 446     });
 447
 448     my %message;
 449
 450     try {
 451         %message = $ct->save_trial();
 452     } catch {
 453         $c->stash->{rest} = {error => "Error saving trial in the database $_"};
 454     };
 455
 456
 457     $c->stash->{rest} = {
 458         message => "Successfully stored the trial.",
 459         trial_id => $message{trial_id},
 460     };
 461     #print STDERR Dumper(%message);
 462 }
 463
 464
 465 # this version of the genotype trial requires the upload of a file from the IGD
 466 #
 467 sub igd_genotype_trial : Path('/ajax/breeders/igdgenotypetrial') Args(0) {
 468     my $self = shift;
 469     my $c = shift;
 470
 471     if (!($c->user()->check_roles('curator') || $c->user()->check_roles('submitter'))) {
 472         $c->stash->{rest} = { error => 'You do not have the required privileges to create a genotyping trial.' };
 473         return;
 474     }
 475     my $schema = $c->dbic_schema("Bio::Chado::Schema");
 476     my $list_id = $c->req->param("list_id");
 477     #my $name = $c->req->param("name");
 478     my $breeding_program_id = $c->req->param("breeding_program");
 479     my $description = $c->req->param("description");
 480     my $location_id = $c->req->param("location");
 481     my $year = $c->req->param("year");
 482     my $upload = $c->req->upload('igd_genotyping_trial_upload_file');
 483     my $upload_tempfile  = $upload->tempname;
 484     my $upload_original_name = $upload->filename();
 485     my $upload_contents = read_file($upload_tempfile);
 486
 487     print STDERR "Parsing IGD file...\n";
 488
 489     my $p = CXGN::Trial::ParseUpload->new( { chado_schema => $schema, filename=>$upload_tempfile });
 490     $p->load_plugin("ParseIGDFile");
 491
 492     my $meta = $p->parse();
 493
 494     my $errors = $p->get_parse_errors();
 495     if (@{$errors->{'error_messages'}}) {
 496         $c->stash->{rest} = { error => "The file has the following problems: ".join ", ", @{$errors->{'error_messages'}}.". Please fix these problems and try again." };
 497         print STDERR "Parsing errors in uploaded file. Aborting. (".join ",", @{$errors->{'error_messages'}}.")\n";
 498         return;
 499     }
 500     print STDERR "Meta information from genotyping trial file: ".Dumper($meta);
 501
 502     my $list = CXGN::List->new( { dbh => $c->dbc->dbh(), list_id => $list_id });
 503     my $elements = $list->elements();
 504
 505     print STDERR "PARAMS: $upload_original_name, $list_id, $breeding_program_id, $location_id, $year\n";
 506     if (!$upload_original_name || !$list_id || !$breeding_program_id || !$location_id || !$year) {
 507         $c->stash->{rest} = { error => "Please provide all parameters, including a file." };
 508         return;
 509     }
 510
 511     print STDERR "Looking up stock names and converting to IGD accepted names...\n";
 512
 513     my $slu = CXGN::Stock::StockLookup->new({ schema => $schema });
 514
 515     # remove non-word characters from names as required by
 516     # IGD naming conventions. Store new names as synonyms.
 517     #
 518     foreach my $e (@$elements) {
 519         my $submission_name = $e;
 520         $submission_name =~ s/\W/\_/g;
 521
 522         print STDERR "Replacing element $e with $submission_name\n";
 523         $slu->set_stock_name($e);
 524         my $s = $slu -> get_stock();
 525         $slu->set_stock_name($submission_name);
 526
 527         print STDERR "Storing synonym $submission_name for $e\n";
 528         $slu->set_stock_name($e);
 529         eval {
 530             #my $rs = $slu->_get_stock_resultset();
 531             $s->create_stockprops(
 532                 { igd_synonym => $submission_name },
 533                 {  autocreate => 1,
 534                    'cv.name' => 'local',
 535                 });
 536         };
 537         if ($@) {
 538             print STDERR "[warning] An error occurred storing the synonym: $submission_name because of $@\n";
 539         }
 540     }
 541
 542     print STDERR "Creating new trial design...\n";
 543
 544     my $td = CXGN::Trial::TrialDesign->new( { schema => $schema });
 545
 546     $td->set_stock_list($elements);
 547     $td->set_block_size(96);
 548     $td->set_blank($meta->{blank_well});
 549     $td->set_trial_name($meta->{trial_name});
 550     $td->set_design_type("genotyping_plate");
 551
 552     my $design;
 553
 554     eval {
 555         $td->calculate_design();
 556     };
 557
 558     if ($@) {
 559         $c->stash->{rest} = { error => "Design failed. Error: $@" };
 560         print STDERR "Design failed because of $@\n";
 561         return;
 562     }
 563
 564     $design = $td->get_design();
 565
 566     if (exists($design->{error})) {
 567         $c->stash->{rest} = $design;
 568         return;
 569     }
 570     #print STDERR Dumper($design);
 571
 572     my $location = $schema->resultset("NaturalDiversity::NdGeolocation")->find( { nd_geolocation_id => $location_id } );
 573     if (!$location) {
 574         $c->stash->{rest} = { error => "Unknown location" };
 575         return;
 576     }
 577
 578     my $breeding_program = $schema->resultset("Project::Project")->find( { project_id => $breeding_program_id });
 579     if (!$breeding_program) {
 580         $c->stash->{rest} = { error => "Unknown breeding program" };
 581         return;
 582     }
 583
 584     print STDERR "Creating the trial...\n";
 585
 586     my $ct = CXGN::Trial::TrialCreate->new( {
 587         chado_schema => $schema,
 588         phenome_schema => $c->dbic_schema("CXGN::Phenome::Schema"),
 589         metadata_schema => $c->dbic_schema("CXGN::Metadata::Schema"),
 590         dbh => $c->dbc->dbh(),
 591         user_name => $c->user()->get_object()->get_username(),
 592         trial_year => $year,
 593         trial_location => $location->description(),
 594         program => $breeding_program->name(),
 595         trial_description => $description || "",
 596         design_type => 'genotyping_plate',
 597         design => $design,
 598         trial_name => $meta->{trial_name},
 599         is_genotyping => 1,
 600         genotyping_user_id => $meta->{user_id} || "unknown",
 601         genotyping_project_name => $meta->{project_name} || "unknown",
 602     });
 603
 604     my %message;
 605
 606     eval {
 607         %message = $ct->save_trial();
 608     };
 609
 610     if ($@ || exists($message{error})) {
 611         $c->stash->{rest} = {
 612             error => "Error saving the trial. $@ $message{error}"
 613         };
 614         print STDERR "Error saving trial\n";
 615         return;
 616     }
 617     $c->stash->{rest} = {
 618         message => "Successfully stored the trial.",
 619         trial_id => $message{trial_id},
 620     };
 621     #print STDERR Dumper(%message);
 622 }
 623
 624
 625 1;