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 utf8;
  14 use JSON;
  15
  16 BEGIN { extends 'Catalyst::Controller::REST'; }
  17
  18 __PACKAGE__->config(
  19     default   => 'application/json',
  20     stash_key => 'rest',
  21     map       => { 'application/json' => 'JSON', 'text/html' => 'JSON'  },
  22    );
  23
  24 has 'schema' => (
  25                  is       => 'rw',
  26                  isa      => 'DBIx::Class::Schema',
  27                  lazy_build => 1,
  28                 );
  29
  30
  31 sub upload_pedigrees_verify : Path('/ajax/pedigrees/upload_verify') Args(0)  {
  32     my $self = shift;
  33     my $c = shift;
  34     my $session_id = $c->req->param("sgn_session_id");
  35     my $user_id;
  36     my $user_name;
  37     my $user_role;
  38
  39     if ($session_id){
  40         my $dbh = $c->dbc->dbh;
  41         my @user_info = CXGN::Login->new($dbh)->query_from_cookie($session_id);
  42         if (!$user_info[0]){
  43             $c->stash->{rest} = {error=>'You must be logged in to upload pedigrees!'};
  44             $c->detach();
  45         }
  46         $user_id = $user_info[0];
  47         $user_role = $user_info[1];
  48         my $p = CXGN::People::Person->new($dbh, $user_id);
  49         $user_name = $p->get_username;
  50     } else {
  51         if (!$c->user()){
  52             $c->stash->{rest} = {error=>'You must be logged in to upload pedigrees!'};
  53             $c->detach();
  54         }
  55         $user_id = $c->user()->get_object()->get_sp_person_id();
  56         $user_name = $c->user()->get_object()->get_username();
  57         $user_role = $c->user->get_object->get_user_type();
  58     }
  59
  60     if (($user_role ne 'curator') && ($user_role ne 'submitter')) {
  61         $c->stash->{rest} = {error=>'Only a submitter or a curator can upload pedigrees'};
  62         $c->detach();
  63     }
  64
  65     my $time = DateTime->now();
  66     my $timestamp = $time->ymd()."_".$time->hms();
  67     my $subdirectory = 'pedigree_upload';
  68     my $upload = $c->req->upload('pedigrees_uploaded_file');
  69     my $upload_tempfile  = $upload->tempname;
  70     my $upload_original_name  = $upload->filename();
  71
  72     my $schema = $c->dbic_schema("Bio::Chado::Schema", undef, $user_id);
  73     my $md5;
  74
  75     my $params = {
  76         tempfile => $upload_tempfile,
  77         subdirectory => $subdirectory,
  78         archive_path => $c->config->{archive_path},
  79         archive_filename => $upload_original_name,
  80         timestamp => $timestamp,
  81         user_id => $user_id,
  82         user_role => $user_role,
  83     };
  84
  85     my $uploader = CXGN::UploadFile->new( $params );
  86
  87     my %upload_metadata;
  88     my $archived_filename_with_path = $uploader->archive();
  89
  90     if (!$archived_filename_with_path) {
  91         $c->stash->{rest} = {error => "Could not save file $upload_original_name in archive",};
  92         return;
  93     }
  94
  95     $md5 = $uploader->get_md5($archived_filename_with_path);
  96     unlink $upload_tempfile;
  97
  98     my $parser = CXGN::Pedigree::ParseUpload->new(chado_schema => $schema, filename => $archived_filename_with_path);
  99     $parser->load_plugin('PedigreesGeneric');
 100     my $parsed_data = $parser->parse();
 101
 102     if (!$parsed_data) {
 103         my $return_error = '';
 104         my $parse_errors;
 105         if (!$parser->has_parse_errors() ){
 106             $c->stash->{rest} = {error_string => "Could not get parsing errors"};
 107             $c->detach();
 108         } else {
 109             $parse_errors = $parser->get_parse_errors();
 110             my $error_messages = $parse_errors->{'error_messages'};
 111             foreach my $error_string (@$error_messages){
 112                 $return_error .= $error_string."<br>";
 113             }
 114         }
 115         $c->stash->{rest} = {error_string => $return_error};
 116         $c->detach();
 117     }
 118
 119     my $pedigree_check = $parsed_data->{'pedigree_check'};
 120     my $pedigree_data = $parsed_data->{'pedigree_data'};
 121
 122     my $pedigrees_hash = {};
 123     $pedigrees_hash->{'pedigrees'} = $pedigree_data;
 124
 125     my $pedigree_string = encode_json $pedigrees_hash;
 126     my $pedigree_info = '';
 127     if ($pedigree_check) {
 128         foreach my $pedigree (@$pedigree_check){
 129             $pedigree_info .= $pedigree."<br>";
 130         }
 131         $c->stash->{rest} = {error => $pedigree_info, pedigree_data => $pedigree_string };
 132     } else {
 133         $c->stash->{rest} = {pedigree_data => $pedigree_string};
 134     }
 135
 136 }
 137
 138 sub upload_pedigrees_store : Path('/ajax/pedigrees/upload_store') Args(0)  {
 139     my $self = shift;
 140     my $c = shift;
 141     my $pedigree_data = $c->req->param('pedigree_data');
 142     my $overwrite_pedigrees = $c->req->param('overwrite_pedigrees') ne 'false' ? $c->req->param('overwrite_pedigrees') : 0;
 143     my $sp_person_id = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
 144     my $schema = $c->dbic_schema("Bio::Chado::Schema", undef, $sp_person_id);
 145
 146     my $pedigree_hash = decode_json $pedigree_data;
 147     my $file_pedigree_info = $pedigree_hash->{'pedigrees'};
 148
 149     my $pedigrees = CXGN::Pedigree::AddPedigrees->new({ schema => $schema });
 150
 151     my $generated_pedigrees = $pedigrees->generate_pedigrees($file_pedigree_info);
 152
 153     my $add = CXGN::Pedigree::AddPedigrees->new({ schema => $schema, pedigrees => $generated_pedigrees });
 154     my $error;
 155
 156     my $return = $add->add_pedigrees($overwrite_pedigrees);
 157
 158     if (!$return){
 159         $error = "The pedigrees were not stored";
 160     }
 161     if ($return->{error}){
 162         $error = $return->{error};
 163     }
 164
 165     if ($error){
 166         $c->stash->{rest} = { error => $error };
 167         $c->detach();
 168     }
 169     $c->stash->{rest} = { success => 1 };
 170 }
 171
 172
 173 =head2 get_full_pedigree
 174
 175 Usage:
 176     GET "/ajax/pedigrees/get_full?stock_id=<STOCK_ID>";
 177
 178 Responds with JSON array containing pedigree relationship objects for the
 179 accession identified by STOCK_ID and all of its parents (recursively).
 180
 181 =cut
 182
 183 sub get_full_pedigree : Path('/ajax/pedigrees/get_full') : ActionClass('REST') { }
 184 sub get_full_pedigree_GET {
 185     my $self = shift;
 186     my $c = shift;
 187     my $stock_id = $c->req->param('stock_id');
 188     my $sp_person_id = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
 189     my $schema = $c->dbic_schema("Bio::Chado::Schema", undef, $sp_person_id);
 190     my $mother_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'female_parent', 'stock_relationship')->cvterm_id();
 191     my $father_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'male_parent', 'stock_relationship')->cvterm_id();
 192     my $accession_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'accession', 'stock_type')->cvterm_id();
 193     my @queue = ($stock_id);
 194     my $nodes = [];
 195     while (@queue){
 196         my $node = pop @queue;
 197         my $relationships = _get_relationships($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, $node);
 198         if ($relationships->{parents}->{mother}){
 199             push @queue, $relationships->{parents}->{mother};
 200         }
 201         if ($relationships->{parents}->{father}){
 202             push @queue, $relationships->{parents}->{father};
 203         }
 204         push @{$nodes}, $relationships;
 205     }
 206     $c->stash->{rest} = $nodes;
 207 }
 208
 209 =head2 get_relationships
 210
 211 Usage:
 212     POST "/ajax/pedigrees/get_relationships";
 213     BODY "stock_id=<STOCK_ID>[&stock_id=<STOCK_ID>...]"
 214
 215 Responds with JSON array containing pedigree relationship objects for the
 216 accessions identified by the provided STOCK_IDs.
 217
 218 =cut
 219
 220 sub get_relationships : Path('/ajax/pedigrees/get_relationships') : ActionClass('REST') { }
 221 sub get_relationships_POST {
 222     my $self = shift;
 223     my $c = shift;
 224     my $stock_ids = [];
 225     my $s_ids = $c->req->body_params->{stock_id};
 226     push @{$stock_ids}, (ref $s_ids eq 'ARRAY' ? @$s_ids : $s_ids);
 227     my $sp_person_id = $c->user() ? $c->user->get_object()->get_sp_person_id() : undef;
 228     my $schema = $c->dbic_schema("Bio::Chado::Schema", undef, $sp_person_id);
 229     my $mother_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'female_parent', 'stock_relationship')->cvterm_id();
 230     my $father_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'male_parent', 'stock_relationship')->cvterm_id();
 231     my $accession_cvterm = SGN::Model::Cvterm->get_cvterm_row($schema, 'accession', 'stock_type')->cvterm_id();
 232     my $nodes = [];
 233     while (@{$stock_ids}){
 234         push @{$nodes}, _get_relationships($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, (shift @{$stock_ids}));
 235     }
 236     $c->stash->{rest} = $nodes;
 237 }
 238
 239 sub _get_relationships {
 240     my $schema = shift;
 241     my $mother_cvterm = shift;
 242     my $father_cvterm = shift;
 243     my $accession_cvterm = shift;
 244     my $stock_id = shift;
 245     my $name = $schema->resultset("Stock::Stock")->find({stock_id=>$stock_id})->uniquename();
 246     my $parents = _get_pedigree_parents($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, $stock_id);
 247     my $children = _get_pedigree_children($schema, $mother_cvterm, $father_cvterm, $accession_cvterm, $stock_id);
 248     return {
 249         id => $stock_id,
 250         name=>$name,
 251         parents=> $parents,
 252         children=> $children
 253     };
 254 }
 255
 256 sub _get_pedigree_parents {
 257     my $schema = shift;
 258     my $mother_cvterm = shift;
 259     my $father_cvterm = shift;
 260     my $accession_cvterm = shift;
 261     my $stock_id = shift;
 262     my $edges = $schema->resultset("Stock::StockRelationship")->search([
 263         {
 264             'me.object_id' => $stock_id,
 265             'me.type_id' => $father_cvterm,
 266             'subject.type_id'=> $accession_cvterm
 267         },
 268         {
 269             'me.object_id' => $stock_id,
 270             'me.type_id' => $mother_cvterm,
 271             'subject.type_id'=> $accession_cvterm
 272         }
 273     ],{join => 'subject'});
 274     my $parents = {};
 275     while (my $edge = $edges->next) {
 276         if ($edge->type_id==$mother_cvterm){
 277             $parents->{mother}=$edge->subject_id;
 278         } else {
 279             $parents->{father}=$edge->subject_id;
 280         }
 281     }
 282     return $parents;
 283 }
 284
 285 sub _get_pedigree_children {
 286     my $schema = shift;
 287     my $mother_cvterm = shift;
 288     my $father_cvterm = shift;
 289     my $accession_cvterm = shift;
 290     my $stock_id = shift;
 291     my $edges = $schema->resultset("Stock::StockRelationship")->search([
 292         {
 293             'me.subject_id' => $stock_id,
 294             'me.type_id' => $father_cvterm,
 295             'object.type_id'=> $accession_cvterm
 296         },
 297         {
 298             'me.subject_id' => $stock_id,
 299             'me.type_id' => $mother_cvterm,
 300             'object.type_id'=> $accession_cvterm
 301         }
 302     ],{join => 'object'});
 303     my $children = {};
 304     $children->{mother_of}=[];
 305     $children->{father_of}=[];
 306     while (my $edge = $edges->next) {
 307         if ($edge->type_id==$mother_cvterm){
 308             push @{$children->{mother_of}}, $edge->object_id;
 309         } else {
 310             push @{$children->{father_of}}, $edge->object_id;
 311         }
 312     }
 313     return $children;
 314 }
 315
 316 # sub _trait_overlay {
 317 #     my $schema = shift;
 318 #     my $node_list = shift;
 319 # }
 320
 321
 322 1;