lib/SGN/Controller/AJAX/Pedigrees.pm

   1
   2 package SGN::Controller::AJAX::Pedigrees;
   3
   4 use Moose;
   5 use List::Util qw | any |;
   6 use File::Slurp qw | read_file |;
   7 use Data::Dumper;
   8 use Bio::GeneticRelationships::Individual;
   9 use Bio::GeneticRelationships::Pedigree;
  10 use CXGN::Pedigree::AddPedigrees;
  11 use CXGN::List::Validate;
  12 use SGN::Model::Cvterm;
  13 use JSON;
  14
  15 BEGIN { extends 'Catalyst::Controller::REST'; }
  16
  17 __PACKAGE__->config(
  18     default   => 'application/json',
  19     stash_key => 'rest',
  20     map       => { 'application/json' => 'JSON', 'text/html' => 'JSON' },
  21    );
  22
  23 has 'schema' => (
  24                  is       => 'rw',
  25                  isa      => 'DBIx::Class::Schema',
  26                  lazy_build => 1,
  27                 );
  28
  29
  30 sub upload_pedigrees_verify : Path('/ajax/pedigrees/upload_verify') Args(0)  {
  31     my $self = shift;
  32     my $c = shift;
  33
  34     if (!$c->user()) {
  35         print STDERR "User not logged in... not uploading pedigrees.\n";
  36         $c->stash->{rest} = {error => "You need to be logged in to upload pedigrees." };
  37         return;
  38     }
  39
  40     if (!any { $_ eq "curator" || $_ eq "submitter" } ($c->user()->roles)  ) {
  41         $c->stash->{rest} = {error =>  "You have insufficient privileges to add pedigrees." };
  42         return;
  43     }
  44
  45     my $time = DateTime->now();
  46     my $user_id = $c->user()->get_object()->get_sp_person_id();
  47     my $user_name = $c->user()->get_object()->get_username();
  48     my $timestamp = $time->ymd()."_".$time->hms();
  49     my $subdirectory = 'pedigree_upload';
  50
  51     my $upload = $c->req->upload('pedigrees_uploaded_file');
  52     my $upload_tempfile  = $upload->tempname;
  53
  54 #    my $temp_contents = read_file($upload_tempfile);
  55 #    $c->stash->{rest} = { error => $temp_contents };
  56 #    return;
  57
  58     my $upload_original_name  = $upload->filename();
  59
  60     # check file type by file name extension
  61     #
  62     if ($upload_original_name =~ /\.xls$|\.xlsx/) {
  63         $c->stash->{rest} = { error => "Pedigree upload requires a tab delimited file. Excel files (.xls and .xlsx) are currently not supported. Please convert the file and try again." };
  64         return;
  65     }
  66
  67     my $md5;
  68     print STDERR "TEMP FILE: $upload_tempfile\n";
  69     my $uploader = CXGN::UploadFile->new({
  70       tempfile => $upload_tempfile,
  71       subdirectory => $subdirectory,
  72       archive_path => $c->config->{archive_path},
  73       archive_filename => $upload_original_name,
  74       timestamp => $timestamp,
  75       user_id => $user_id,
  76       user_role => $c->user()->roles
  77     });
  78
  79     my %upload_metadata;
  80     my $archived_filename_with_path = $uploader->archive();
  81
  82     if (!$archived_filename_with_path) {
  83         $c->stash->{rest} = {error => "Could not save file $upload_original_name in archive",};
  84         return;
  85     }
  86
  87     $md5 = $uploader->get_md5($archived_filename_with_path);
  88     unlink $upload_tempfile;
  89
  90     # check if all accessions exist
  91     #
  92     open(my $F, "<", $archived_filename_with_path) || die "Can't open archive file $archived_filename_with_path";
  93     my $schema = $c->dbic_schema("Bio::Chado::Schema");
  94     my %stocks;
  95
  96     my $header = <$F>;
  97     my %legal_cross_types = ( biparental => 1, open => 1, self => 1);
  98     my %errors;
  99
 100     while (<$F>) {
 101         chomp;
 102         $_ =~ s/\r//g;
 103         my @acc = split /\t/;
 104         for(my $i=0; $i<3; $i++) {
 105             if ($acc[$i] =~ /\,/) {
 106                 my @a = split /\s*\,\s*/, $acc[$i];  # a comma separated list for an open pollination can be given
 107                 foreach (@a) { $stocks{$_}++ if $_ };
 108             }
 109             else {
 110                 $stocks{$acc[$i]}++ if $acc[$i];
 111             }
 112         }
 113         # check if the cross types are recognized...
 114         if ($acc[3] && !exists($legal_cross_types{lc($acc[3])})) {
 115             $errors{"not legal cross type: $acc[3] (should be biparental, self, or open)"}=1;
 116         }
 117     }
 118     close($F);
 119     my @unique_stocks = keys(%stocks);
 120     my $accession_validator = CXGN::List::Validate->new();
 121     my @accessions_missing = @{$accession_validator->validate($schema,'accessions_or_populations',\@unique_stocks)->{'missing'}};
 122     if (scalar(@accessions_missing)>0){
 123         $errors{"The following accessions are not in the database: ".(join ",", @accessions_missing)} = 1;
 124     }
 125
 126     if (%errors) {
 127         $c->stash->{rest} = { error => "There were problems loading the pedigree for the following accessions: ".(join ",", keys(%errors)).". Please fix these errors and try again. (errors: ".(join ", ", values(%errors)).")" };
 128         return;
 129     }
 130
 131     print STDERR "UploadPedigreeCheck1".localtime()."\n";
 132     my $pedigrees = _get_pedigrees_from_file($c, $archived_filename_with_path);
 133     print STDERR "UploadPedigreeCheck2".localtime()."\n";
 134
 135     my $add = CXGN::Pedigree::AddPedigrees->new({ schema=>$schema, pedigrees=>$pedigrees });
 136     my $error;
 137
 138     my $pedigree_check = $add->validate_pedigrees();
 139     print STDERR "UploadPedigreeCheck3".localtime()."Complete\n";
 140     #print STDERR Dumper $pedigree_check;
 141     if (!$pedigree_check){
 142         $error = "There was a problem validating pedigrees. Pedigrees were not stored.";
 143     }
 144     if ($pedigree_check->{error}){
 145         $c->stash->{rest} = {error => $pedigree_check->{error}, archived_file_name => $archived_filename_with_path};
 146     } else {
 147         $c->stash->{rest} = {archived_file_name => $archived_filename_with_path};
 148     }
 149 }
 150
 151 sub upload_pedigrees_store : Path('/ajax/pedigrees/upload_store') Args(0)  {
 152     my $self = shift;
 153     my $c = shift;
 154     my $archived_file_name = $c->req->param('archived_file_name');
 155     my $overwrite_pedigrees = $c->req->param('overwrite_pedigrees') ne 'false' ? $c->req->param('overwrite_pedigrees') : 0;
 156     my $schema = $c->dbic_schema("Bio::Chado::Schema");
 157
 158     my $pedigrees = _get_pedigrees_from_file($c, $archived_file_name);
 159
 160     my $add = CXGN::Pedigree::AddPedigrees->new({ schema=>$schema, pedigrees=>$pedigrees });
 161     my $error;
 162
 163     my $return = $add->add_pedigrees($overwrite_pedigrees);
 164     #print STDERR Dumper $return;
 165     if (!$return){
 166         $error = "The pedigrees were not stored";
 167     }
 168     if ($return->{error}){
 169         $error = $return->{error};
 170     }
 171
 172     if ($error){
 173         $c->stash->{rest} = { error => $error };
 174         $c->detach();
 175     }
 176     $c->stash->{rest} = { success => 1 };
 177 }
 178
 179 sub _get_pedigrees_from_file {
 180     my $c = shift;
 181     my $archived_filename_with_path = shift;
 182
 183     open(my $F, "<", $archived_filename_with_path) || die "Can't open file $archived_filename_with_path";
 184     my $header = <$F>;
 185     my @pedigrees;
 186     my $line_num = 2;
 187     while (<$F>) {
 188         my $female_parent;
 189         my $male_parent;
 190         chomp;
 191         $_ =~ s/\r//g;
 192         my ($progeny, $female, $male, $cross_type) = split /\t/;
 193
 194         if (!$female && !$male) {
 195             $c->stash->{rest} = { error => "No male parent and no female parent on line $line_num!" };
 196             $c->detach();
 197         }
 198         if (!$progeny) {
 199             $c->stash->{rest} = { error => "No progeny specified on line $line_num!" };
 200             $c->detach();
 201         }
 202         if (!$female) {
 203             $c->stash->{rest} = { error => "No female parent on line $line_num for $progeny!" };
 204             $c->detach();
 205         }
 206         if (!$cross_type){
 207             $c->stash->{rest} = { error => "No cross type on line $line_num! Muse be one of these: biparental,open,self." };
 208             $c->detach();
 209         }
 210         if ($cross_type ne 'biparental' && $cross_type ne 'open' && $cross_type ne 'self'){
 211             $c->stash->{rest} = { error => "Invalid cross type on line $line_num! Must be one of these: biparental,open,self." };
 212             $c->detach();
 213         }
 214
 215         if (($female eq $male) && ($cross_type ne 'self')) {
 216             $c->stash->{rest} = { error => "Female parent and male parent are the same on line $line_num, but cross type is not self." };
 217             $c->detach();
 218         }
 219
 220         if (($female && !$male) && ($cross_type ne 'open')) {
 221             $c->stash->{rest} = { error => "For $progeny on line number $line_num no male parent specified and cross_type is not open..." };
 222             $c->detach();
 223         }
 224
 225         if($cross_type eq "self") {
 226             $female_parent = Bio::GeneticRelationships::Individual->new( { name => $female });
 227             $male_parent = Bio::GeneticRelationships::Individual->new( { name => $female });
 228         }
 229         elsif($cross_type eq "biparental") {
 230             if (!$male){
 231                 $c->stash->{rest} = { error => "For $progeny Cross Type is biparental, but no male parent given" };
 232                 $c->detach();
 233             }
 234             $female_parent = Bio::GeneticRelationships::Individual->new( { name => $female });
 235             $male_parent = Bio::GeneticRelationships::Individual->new( { name => $male });
 236         }
 237         elsif($cross_type eq "open") {
 238             $female_parent = Bio::GeneticRelationships::Individual->new( { name => $female });
 239             $male_parent = undef;
 240             if ($male){
 241                 $male_parent = Bio::GeneticRelationships::Individual->new( { name => $male });
 242             }
 243
 244         }
 245
 246         my $opts = {
 247             cross_type => $cross_type,
 248             female_parent => $female_parent,
 249             name => $progeny
 250         };
 251
 252         if ($male_parent) {
 253             $opts->{male_parent} = $male_parent;
 254         }
 255
 256         my $p = Bio::GeneticRelationships::Pedigree->new($opts);
 257         push @pedigrees, $p;
 258         $line_num++;
 259     }
 260     return \@pedigrees;
 261 }
 262
 263 =head2 get_full_pedigree
 264
 265 Usage:
 266     GET "/ajax/pedigrees/get_full?stock_id=<STOCK_ID>";
 267
 268 Responds with JSON array containing pedigree relationship objects for the
 269 accession identified by STOCK_ID and all of its parents (recursively).
 270
 271 =cut
 272
 273 sub get_full_pedigree : Path('/ajax/pedigrees/get_full') : ActionClass('REST') { }
 274 sub get_full_pedigree_GET {
 275     my $self = shift;
 276     my $c = shift;
 277     my $stock_id = $c->req->param('stock_id');
 278     my $schema = $c->dbic_schema("Bio::Chado::Schema");
 279     my $mother_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'female_parent', 'stock_relationship')->cvterm_id();
 280     my $father_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'male_parent', 'stock_relationship')->cvterm_id();
 281     my $accession_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'accession', 'stock_type')->cvterm_id();
 282     my @queue = ($stock_id);
 283     my $nodes = [];
 284     while (@queue){
 285         my $node = pop @queue;
 286         my $relationships = _get_relationships($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, $node);
 287         if ($relationships->{parents}->{mother}){
 288             push @queue, $relationships->{parents}->{mother};
 289         }
 290         if ($relationships->{parents}->{father}){
 291             push @queue, $relationships->{parents}->{father};
 292         }
 293         push @{$nodes}, $relationships;
 294     }
 295     $c->stash->{rest} = $nodes;
 296 }
 297
 298 =head2 get_relationships
 299
 300 Usage:
 301     POST "/ajax/pedigrees/get_relationships";
 302     BODY "stock_id=<STOCK_ID>[&stock_id=<STOCK_ID>...]"
 303
 304 Responds with JSON array containing pedigree relationship objects for the
 305 accessions identified by the provided STOCK_IDs.
 306
 307 =cut
 308
 309 sub get_relationships : Path('/ajax/pedigrees/get_relationships') : ActionClass('REST') { }
 310 sub get_relationships_POST {
 311     my $self = shift;
 312     my $c = shift;
 313     my $stock_ids = [];
 314     my $s_ids = $c->req->body_params->{stock_id};
 315     push @{$stock_ids}, (ref $s_ids eq 'ARRAY' ? @$s_ids : $s_ids);
 316     my $schema = $c->dbic_schema("Bio::Chado::Schema");
 317     my $mother_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'female_parent', 'stock_relationship')->cvterm_id();
 318     my $father_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'male_parent', 'stock_relationship')->cvterm_id();
 319     my $accession_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'accession', 'stock_type')->cvterm_id();
 320     my $nodes = [];
 321     while (@{$stock_ids}){
 322         push @{$nodes}, _get_relationships($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, (shift @{$stock_ids}));
 323     }
 324     $c->stash->{rest} = $nodes;
 325 }
 326
 327 sub _get_relationships {
 328     my $schema = shift;
 329     my $mother_cvterm = shift;
 330     my $father_cvterm = shift;
 331     my $accession_cvterm = shift;
 332     my $stock_id = shift;
 333     my $name = $schema->resultset("Stock::Stock")->find({stock_id=>$stock_id})->uniquename();
 334     my $parents = _get_pedigree_parents($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, $stock_id);
 335     my $children = _get_pedigree_children($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, $stock_id);
 336     return {
 337         id => $stock_id,
 338         name=>$name,
 339         parents=> $parents,
 340         children=> $children
 341     };
 342 }
 343
 344 sub _get_pedigree_parents {
 345     my $schema = shift;
 346     my $mother_cvterm = shift;
 347     my $father_cvterm = shift;
 348     my $accession_cvterm = shift;
 349     my $stock_id = shift;
 350     my $edges = $schema->resultset("Stock::StockRelationship")->search([
 351         {
 352             'me.object_id' => $stock_id,
 353             'me.type_id' => $father_cvterm,
 354             'subject.type_id'=> $accession_cvterm
 355         },
 356         {
 357             'me.object_id' => $stock_id,
 358             'me.type_id' => $mother_cvterm,
 359             'subject.type_id'=> $accession_cvterm
 360         }
 361     ],{join => 'subject'});
 362     my $parents = {};
 363     while (my $edge = $edges->next) {
 364         if ($edge->type_id==$mother_cvterm){
 365             $parents->{mother}=$edge->subject_id;
 366         } else {
 367             $parents->{father}=$edge->subject_id;
 368         }
 369     }
 370     return $parents;
 371 }
 372
 373 sub _get_pedigree_children {
 374     my $schema = shift;
 375     my $mother_cvterm = shift;
 376     my $father_cvterm = shift;
 377     my $accession_cvterm = shift;
 378     my $stock_id = shift;
 379     my $edges = $schema->resultset("Stock::StockRelationship")->search([
 380         {
 381             'me.subject_id' => $stock_id,
 382             'me.type_id' => $father_cvterm,
 383             'object.type_id'=> $accession_cvterm
 384         },
 385         {
 386             'me.subject_id' => $stock_id,
 387             'me.type_id' => $mother_cvterm,
 388             'object.type_id'=> $accession_cvterm
 389         }
 390     ],{join => 'object'});
 391     my $children = {};
 392     $children->{mother_of}=[];
 393     $children->{father_of}=[];
 394     while (my $edge = $edges->next) {
 395         if ($edge->type_id==$mother_cvterm){
 396             push @{$children->{mother_of}}, $edge->object_id;
 397         } else {
 398             push @{$children->{father_of}}, $edge->object_id;
 399         }
 400     }
 401     return $children;
 402 }
 403
 404 # sub _trait_overlay {
 405 #     my $schema = shift;
 406 #     my $node_list = shift;
 407 # }
 408
 409
 410 1;