lib/SGN/Controller/Stock.pm

   1 package SGN::Controller::Stock;
   2
   3 =head1 NAME
   4
   5 SGN::Controller::Stock - Catalyst controller for pages dealing with
   6 stocks (e.g. accession, population, etc.)
   7
   8 =cut
   9
  10 use Moose;
  11 use namespace::autoclean;
  12 use YAML::Any qw/LoadFile/;
  13
  14 use URI::FromHash 'uri';
  15 use List::Compare;
  16 use File::Temp qw / tempfile /;
  17 use File::Slurp;
  18 use JSON::Any;
  19
  20 use CXGN::Chado::Stock;
  21 use SGN::View::Stock qw/stock_link stock_organisms stock_types breeding_programs /;
  22 use Bio::Chado::NaturalDiversity::Reports;
  23 use SGN::Model::Cvterm;
  24
  25 BEGIN { extends 'Catalyst::Controller' }
  26 with 'Catalyst::Component::ApplicationAttribute';
  27
  28 has 'schema' => (
  29     is       => 'rw',
  30     isa      => 'DBIx::Class::Schema',
  31     lazy_build => 1,
  32 );
  33 sub _build_schema {
  34     shift->_app->dbic_schema( 'Bio::Chado::Schema', 'sgn_chado' )
  35 }
  36
  37 has 'default_page_size' => (
  38     is      => 'ro',
  39     default => 20,
  40 );
  41
  42 =head1 PUBLIC ACTIONS
  43
  44
  45 =head2 stock search using jQuery data tables
  46
  47 =cut
  48
  49 sub stock_search :Path('/search/stocks') Args(0) {
  50     my ($self, $c ) = @_;
  51     $c->stash(
  52         template => '/search/stocks.mas',
  53
  54         stock_types => stock_types($self->schema),
  55         organisms   => stock_organisms($self->schema) ,
  56         sp_person_autocomplete_uri => $c->uri_for( '/ajax/people/autocomplete' ),
  57         trait_autocomplete_uri     => $c->uri_for('/ajax/stock/trait_autocomplete'),
  58         onto_autocomplete_uri      => $c->uri_for('/ajax/cvterm/autocomplete'),
  59         trait_db_name              => $c->get_conf('trait_ontology_db_name'),
  60         breeding_programs          => breeding_programs($self->schema),
  61         );
  62
  63 }
  64
  65
  66 =head2 search DEPRECATED
  67
  68 Public path: /stock/search
  69
  70 Display a stock search form, or handle stock searching.
  71
  72 =cut
  73
  74 sub search :Path('/stock/search') Args(0) {
  75     my ( $self, $c ) = @_;
  76     $c->stash(
  77         template => '/search/stocks.mas',
  78
  79         stock_types => stock_types($self->schema),
  80         organisms   => stock_organisms($self->schema) ,
  81         sp_person_autocomplete_uri => $c->uri_for( '/ajax/people/autocomplete' ),
  82         trait_autocomplete_uri     => $c->uri_for('/ajax/stock/trait_autocomplete'),
  83         onto_autocomplete_uri      => $c->uri_for('/ajax/cvterm/autocomplete'),
  84         trait_db_name              => $c->get_conf('trait_ontology_db_name'),
  85         breeding_programs          => breeding_programs($self->schema),
  86         );
  87     #my $results = $c->req->param('search_submitted') ? $self->_make_stock_search_rs($c) : undef;
  88     #my $form = HTML::FormFu->new(LoadFile($c->path_to(qw{forms stock stock_search.yaml})));
  89     #my $trait_db_name = $c->get_conf('trait_ontology_db_name');
  90     #$c->stash(
  91     #    template                   => '/search/phenotypes/stock.mas',
  92     #    request                    => $c->req,
  93     #    form                       => $form,
  94     #    form_opts                  => { stock_types => stock_types($self->schema), organisms => stock_organisms($self->schema)} ,
  95     #    results                    => $results,
  96     #    sp_person_autocomplete_uri => $c->uri_for( '/ajax/people/autocomplete' ),
  97     #    trait_autocomplete_uri     => $c->uri_for('/ajax/stock/trait_autocomplete'),
  98     #    onto_autocomplete_uri      => $c->uri_for('/ajax/cvterm/autocomplete'),
  99         #trait_db_name              => $trait_db_name,
 100         #pagination_link_maker      => sub {
 101         #    return uri( query => { %{$c->req->params} , page => shift } );
 102         #},
 103         #);
 104 }
 105
 106 =head2 new_stock
 107
 108 Public path: /stock/0/new
 109
 110 Create a new stock.
 111
 112 Chained off of L</get_stock> below.
 113
 114 =cut
 115
 116 sub new_stock : Chained('get_stock') PathPart('new') Args(0) {
 117     my ( $self, $c ) = @_;
 118     $c->stash(
 119         template => '/stock/new_stock.mas',
 120
 121         stockref => {
 122             action    => "new",
 123             stock_id  => 0 ,
 124             stock     => $c->stash->{stock},
 125             schema    => $self->schema,
 126         },
 127         );
 128 }
 129
 130
 131 =head2 view_stock
 132
 133 Public path: /stock/<stock_id>/view
 134
 135 View a stock's detail page.
 136
 137 Chained off of L</get_stock> below.
 138
 139 =cut
 140
 141 our $time;
 142
 143 sub view_stock : Chained('get_stock') PathPart('view') Args(0) {
 144     my ( $self, $c, $action) = @_;
 145
 146     $time = time();
 147
 148     if( $c->stash->{stock_row} ) {
 149         $c->forward('get_stock_extended_info');
 150     }
 151
 152     my $logged_user = $c->user;
 153     my $person_id = $logged_user->get_object->get_sp_person_id if $logged_user;
 154     my $user_role = 1 if $logged_user;
 155     my $curator   = $logged_user->check_roles('curator') if $logged_user;
 156     my $submitter = $logged_user->check_roles('submitter') if $logged_user;
 157     my $sequencer = $logged_user->check_roles('sequencer') if $logged_user;
 158
 159     my $dbh = $c->dbc->dbh;
 160
 161     ##################
 162
 163     ###Check if a stock page can be printed###
 164
 165     my $stock = $c->stash->{stock};
 166     my $stock_id = $stock ? $stock->get_stock_id : undef ;
 167     my $stock_type = $stock->get_object_row ? $stock->get_object_row->type->name : undef ;
 168     my $type = 1 if $stock_type && !$stock_type=~ m/population/;
 169     # print message if stock_id is not valid
 170     unless ( ( $stock_id =~ m /^\d+$/ ) || ($action eq 'new' && !$stock_id) ) {
 171         $c->throw_404( "No stock/accession exists for that identifier." );
 172     }
 173     unless ( $stock->get_object_row || !$stock_id && $action && $action eq 'new' ) {
 174         $c->throw_404( "No stock/accession exists for that identifier." );
 175     }
 176
 177     print STDERR "Checkpoint 2: Elapsed ".(time() - $time)."\n";
 178
 179     my $props = $self->_stockprops($stock);
 180     # print message if the stock is visible only to certain user roles
 181     my @logged_user_roles = $logged_user->roles if $logged_user;
 182     my @prop_roles = @{ $props->{visible_to_role} } if  ref($props->{visible_to_role} );
 183     my $lc = List::Compare->new( {
 184         lists    => [\@logged_user_roles, \@prop_roles],
 185         unsorted => 1,
 186                               } );
 187     my @intersection = $lc->get_intersection;
 188     if ( !$curator && @prop_roles  && !@intersection) { # if there is no match between user roles and stock visible_to_role props
 189        # $c->throw(is_client_error => 0,
 190        #           title             => 'Restricted page',
 191        #           message           => "Stock $stock_id is not visible to your user!",
 192        #           developer_message => 'only logged in users of certain roles can see this stock' . join(',' , @prop_roles),
 193        #           notify            => 0,   #< does not send an error email
 194        #     );
 195
 196         $c->stash->{template} = "generic_message.mas";
 197         $c->stash->{message}  = "You do not have sufficient privileges to view the page of stock with database id $stock_id. You may need to log in to view this page.";
 198         return;
 199     }
 200
 201     print STDERR "Checkpoint 3: Elapsed ".(time() - $time)."\n";
 202
 203     # print message if the stock is obsolete
 204     my $obsolete = $stock->get_is_obsolete();
 205     if ( $obsolete  && !$curator ) {
 206         #$c->throw(is_client_error => 0,
 207         #          title             => 'Obsolete stock',
 208         #          message           => "Stock $stock_id is obsolete!",
 209         #          developer_message => 'only curators can see obsolete stock',
 210         #          notify            => 0,   #< does not send an error email
 211         #    );
 212
 213         $c->stash->{template} = "generic_message.mas";
 214         $c->stash->{message}  = "The stock with database id $stock_id has been deleted. It can no longer be viewed.";
 215         return;
 216     }
 217     # print message if stock_id does not exist
 218     if ( !$stock && $action ne 'new' && $action ne 'store' ) {
 219         $c->throw_404('No stock exists for this identifier');
 220     }
 221
 222     ####################
 223     my $is_owner;
 224     my $owner_ids = $c->stash->{owner_ids} || [] ;
 225     if ( $stock && ($curator || $person_id && ( grep /^$person_id$/, @$owner_ids ) ) ) {
 226         $is_owner = 1;
 227     }
 228     my $dbxrefs = $self->_dbxrefs($stock);
 229     my $pubs = $self->_stock_pubs($stock);
 230     my $image_ids = $self->_stock_images($stock, $type);
 231     my $cview_tmp_dir = $c->tempfiles_subdir('cview');
 232
 233     my $barcode_tempuri  = $c->tempfiles_subdir('image');
 234     my $barcode_tempdir = $c->get_conf('basepath')."/$barcode_tempuri";
 235
 236     print STDERR "Checkpoint 4: Elapsed ".(time() - $time)."\n";
 237 ################
 238     $c->stash(
 239         template => '/stock/index.mas',
 240
 241         stockref => {
 242             action    => $action,
 243             stock_id  => $stock_id ,
 244             user      => $user_role,
 245             curator   => $curator,
 246             submitter => $submitter,
 247             sequencer => $sequencer,
 248             person_id => $person_id,
 249             stock     => $stock,
 250             schema    => $self->schema,
 251             dbh       => $dbh,
 252             is_owner  => $is_owner,
 253             owners    => $owner_ids,
 254             props     => $props,
 255             dbxrefs   => $dbxrefs,
 256             pubs      => $pubs,
 257             members_phenotypes => $c->stash->{members_phenotypes},
 258             direct_phenotypes  => $c->stash->{direct_phenotypes},
 259             direct_genotypes   => $c->stash->{direct_genotypes},
 260             has_qtl_data   => $c->stash->{has_qtl_data},
 261             cview_tmp_dir  => $cview_tmp_dir,
 262             cview_basepath => $c->get_conf('basepath'),
 263             image_ids      => $image_ids,
 264             allele_count   => $c->stash->{allele_count},
 265             ontology_count => $c->stash->{ontology_count},
 266             has_pedigree => $c->stash->{has_pedigree},
 267             has_descendants => $c->stash->{has_descendants},
 268             trait_ontology_db_name => $c->get_conf('trait_ontology_db_name'),
 269             editable_stock_props   => $c->get_conf('editable_stock_props'),
 270
 271         },
 272         locus_add_uri  => $c->uri_for( '/ajax/stock/associate_locus' ),
 273         cvterm_add_uri => $c->uri_for( '/ajax/stock/associate_ontology'),
 274         barcode_tempdir  => $barcode_tempdir,
 275         barcode_tempuri   => $barcode_tempuri,
 276         identifier_prefix => $c->config->{identifier_prefix},
 277         );
 278 }
 279
 280 =head1 PRIVATE ACTIONS
 281
 282 =head2 download_phenotypes
 283
 284 =cut
 285
 286
 287 sub download_phenotypes : Chained('get_stock') PathPart('phenotypes') Args(0) {
 288     my ($self, $c) = @_;
 289     my $stock = $c->stash->{stock_row};
 290     my $stock_id = $stock->stock_id;
 291     if ($stock_id) {
 292         #my $tmp_dir = $c->get_conf('basepath') . "/" . $c->get_conf('stock_tempfiles');
 293         #my $file_cache = Cache::File->new( cache_root => $tmp_dir  );
 294         #$file_cache->purge();
 295         #my $key = "stock_" . $stock_id . "_phenotype_data";
 296         #my $phen_file = $file_cache->get($key);
 297         #my $filename = $tmp_dir . "/stock_" . $stock_id . "_phenotypes.csv";
 298
 299         my $results = [];# listref for recursive subject stock_phenotypes resultsets
 300         #recursively get the stock_id and the ids of its subjects from stock_relationship
 301         my $stock_rs = $self->schema->resultset("Stock::Stock")->search( { stock_id => $stock_id } );
 302         $results =  $self->schema->resultset("Stock::Stock")->recursive_phenotypes_rs($stock_rs, $results);
 303         my $report = Bio::Chado::NaturalDiversity::Reports->new;
 304         my $d = $report->phenotypes_by_trait($results);
 305
 306         my @info  = split(/\n/ , $d);
 307         my @data;
 308         foreach (@info) {
 309             push @data, [ split(/\t/) ] ;
 310         }
 311         $c->stash->{'csv'}={ data => \@data};
 312         $c->forward("View::Download::CSV");
 313         #stock    repeat        experiment      year    SP:0001 SP:0002
 314     }
 315 }
 316
 317
 318 =head2 download_genotypes
 319
 320 =cut
 321
 322
 323 sub download_genotypes : Chained('get_stock') PathPart('genotypes') Args(0) {
 324     my ($self, $c) = @_;
 325     my $stock = $c->stash->{stock_row};
 326     my $stock_id = $stock->stock_id;
 327     my $stock_name = $stock->uniquename;
 328     if ($stock_id) {
 329
 330         print STDERR "Exporting genotype file...\n";
 331         my $tmp_dir = $c->get_conf('basepath') . "/" . $c->get_conf('stock_tempfiles');
 332         my $file_cache = Cache::File->new( cache_root => $tmp_dir  );
 333         $file_cache->purge();
 334         my $key = "stock_" . $stock_id . "_genotype_data";
 335         my $gen_file = $file_cache->get($key);
 336         my $filename = $tmp_dir . "/stock_" . $stock_id . "_genotypes.csv";
 337         unless ( $gen_file && -e $gen_file) {
 338             my $gen_hashref; #hashref of hashes for the phenotype data
 339             my %cvterms ; #hash for unique cvterms
 340             ##############
 341             my $genotypes =  $self->_stock_project_genotypes( $stock );
 342             write_file($filename, ("project\tmarker\t$stock_name\n") );
 343             foreach my $project (keys %$genotypes ) {
 344                 foreach my $geno (@ { $genotypes->{$project} } ) {
 345                     my $genotypeprop_rs = $geno->search_related('genotypeprops' ); # , {
 346                     #just check if the value type is JSON
 347                     #this is the current genotype we have , add more here as necessary
 348                         #'type.name' => 'infinium array' } , {
 349                         #    join => 'type' } );
 350                     while (my $prop = $genotypeprop_rs->next) {
 351                         my $json_text = $prop->value ;
 352                         my $genotype_values = JSON::Any->decode($json_text);
 353                         my $count = 0;
 354                         my @lines = ();
 355                         foreach my $marker_name (keys %$genotype_values) {
 356                             $count++;
 357                             #if ($count % 1000 == 0) { print STDERR "Processing $count     \r"; }
 358                             my $read = $genotype_values->{$marker_name};
 359                             push @lines, (join "\t", ($project, $marker_name, $read))."\n";
 360                         }
 361                         my @sorted_lines = sort chr_sort @lines;
 362                         write_file($filename, { append=> 1 }, @sorted_lines);
 363                     }
 364                 }
 365             }
 366             $file_cache->set( $key, $filename, '30 days' );
 367             $gen_file = $file_cache->get($key);
 368         }
 369         my @data;
 370
 371         foreach ( read_file($filename) ) {
 372             chomp;
 373             push @data, [ split(/\t/) ];
 374         }
 375         #$c->stash->{'csv'}={ data => \@data};
 376         $c->stash->{'csv'} = \@data;
 377         $c->forward("View::Download::CSV");
 378     }
 379 }
 380
 381 sub chr_sort {
 382     my @a = split "\t", $a;
 383     my @b = split "\t", $b;
 384
 385     my $a_chr;
 386     my $a_coord;
 387     my $b_chr;
 388     my $b_coord;
 389
 390     if ($a[1] =~ /^[A-Za-z]+(\d+)[_-](\d+)$/) {
 391         $a_chr = $1;
 392         $a_coord = $2;
 393     }
 394
 395     if ($b[1] =~ /[A-Za-z]+(\d+)[_-](\d+)/) {
 396         $b_chr = $1;
 397         $b_coord = $2;
 398     }
 399
 400     if ($a_chr eq $b_chr) {
 401         return $a_coord <=> $b_coord;
 402     }
 403     else {
 404         return $a_chr <=> $b_chr;
 405     }
 406 }
 407
 408 =head2 get_stock
 409
 410 Chain root for fetching a stock object to operate on.
 411
 412 Path part: /stock/<stock_id>
 413
 414 =cut
 415
 416 sub get_stock : Chained('/')  PathPart('stock')  CaptureArgs(1) {
 417     my ($self, $c, $stock_id) = @_;
 418
 419     $c->stash->{stock}     = CXGN::Chado::Stock->new($self->schema, $stock_id);
 420     $c->stash->{stock_row} = $self->schema->resultset('Stock::Stock')
 421                                   ->find({ stock_id => $stock_id });
 422 }
 423
 424 #add the stockcvterms to the stash. Props are a hashref of lists.
 425 sub get_stock_cvterms : Private {
 426     my ( $self, $c ) = @_;
 427     my $stock = $c->stash->{stock};
 428     my $stock_cvterms = $stock ? $self->_stock_cvterms($stock, $c) : undef;
 429     $c->stash->{stock_cvterms} = $stock_cvterms;
 430 }
 431
 432 sub get_stock_allele_ids : Private {
 433     my ( $self, $c ) = @_;
 434     my $stock = $c->stash->{stock};
 435     my $allele_ids = $stock ? $self->_stock_allele_ids($stock) : undef;
 436     $c->stash->{allele_ids} = $allele_ids;
 437     my $count = $allele_ids ? scalar( @$allele_ids ) : undef;
 438     $c->stash->{allele_count} = $count ;
 439 }
 440
 441 sub get_stock_owner_ids : Private {
 442     my ( $self, $c ) = @_;
 443     my $stock = $c->stash->{stock};
 444     my $owner_ids = $stock ? $self->_stock_owner_ids($stock) : undef;
 445     $c->stash->{owner_ids} = $owner_ids;
 446 }
 447
 448 sub get_stock_has_pedigree : Private {
 449     my ( $self, $c ) = @_;
 450     my $stock = $c->stash->{stock};
 451     my $has_pedigree = $stock ? $self->_stock_has_pedigree($stock) : undef;
 452     $c->stash->{has_pedigree} = $has_pedigree;
 453 }
 454
 455 sub get_stock_has_descendants : Private {
 456     my ( $self, $c ) = @_;
 457     my $stock = $c->stash->{stock};
 458     my $has_descendants = $stock ? $self->_stock_has_descendants($stock) : undef;
 459     $c->stash->{has_descendants} = $has_descendants;
 460 }
 461
 462 sub get_stock_extended_info : Private {
 463     my ( $self, $c ) = @_;
 464     $c->forward('get_stock_cvterms');
 465
 466     $c->forward('get_stock_allele_ids');
 467     $c->forward('get_stock_owner_ids');
 468     $c->forward('get_stock_has_pedigree');
 469     $c->forward('get_stock_has_descendants');
 470
 471     # look up the stock again, this time prefetching a lot of data about its related stocks
 472     $c->stash->{stock_row} = $self->schema->resultset('Stock::Stock')
 473                                   ->find({ stock_id => $c->stash->{stock_row}->stock_id },
 474                                          { prefetch => {
 475                                              'stock_relationship_objects' => [ { 'subject' => 'type' }, 'type'],
 476                                            },
 477                                          },
 478                                         );
 479
 480     my $stock = $c->stash->{stock};
 481
 482     #add the stock_dbxrefs to the stash. Dbxrefs are hashref of lists.
 483     # keys are db-names , values are lists of Bio::Chado::Schema::General::Dbxref objects
 484     my $dbxrefs  = $stock ?  $self->_stock_dbxrefs($stock) : undef ;
 485     $c->stash->{stock_dbxrefs} = $dbxrefs;
 486
 487     my $cvterms  = $stock ?  $self->_stock_cvterms($stock, $c) : undef ;
 488     $c->stash->{stock_cvterms} = $cvterms;
 489     my $stock_rs = ( $c->stash->{stock_row})->search_related('stock_relationship_subjects')
 490         ->search_related('subject');
 491
 492     my $direct_phenotypes  = $stock ? $self->_stock_project_phenotypes($self->schema->resultset("Stock::Stock")->search_rs({ stock_id => $c->stash->{stock_row}->stock_id } ) ) : undef;
 493     $c->stash->{direct_phenotypes} = $direct_phenotypes;
 494
 495     my ($members_phenotypes, $has_members_genotypes)  = (undef, undef); #$stock ? $self->_stock_members_phenotypes( $c->stash->{stock_row} ) : undef;
 496     $c->stash->{members_phenotypes} = $members_phenotypes;
 497
 498     my $direct_genotypes  = $stock ? $self->_stock_project_genotypes( $c->stash->{stock_row} ) : undef;
 499     $c->stash->{direct_genotypes} = $direct_genotypes;
 500
 501     my $stock_type;
 502     $stock_type = $stock->get_object_row->type->name if $stock->get_object_row;
 503     if ( ( grep { /^$stock_type/ } ('f2 population', 'backcross population') ) &&  $members_phenotypes && $has_members_genotypes ) { $c->stash->{has_qtl_data} = 1 ; }
 504
 505 }
 506
 507 ############## HELPER METHODS ######################3
 508
 509 # assembles a DBIC resultset for the search based on the submitted
 510 # form values
 511 sub _make_stock_search_rs {
 512     my ( $self, $c ) = @_;
 513
 514     my $rs = $self->schema->resultset('Stock::Stock');
 515
 516     if( my $name = $c->req->param('stock_name') ) {
 517         # trim and regularize whitespace
 518         $name =~ s/(^\s+|\s+)$//g;
 519         $name =~ s/\s+/ /g;
 520
 521         $rs = $rs->search({ 'me.is_obsolete' => 'false',
 522             -or => [
 523                  'lower(me.name)' => { like => '%'.lc( $name ).'%' } ,
 524                  'lower(me.uniquename)' => { like => '%'.lc( $name ).'%' },
 525                  -and => [
 526                      'lower(type.name)' => { like =>'%synonym%' },
 527                      'lower(stockprops.value)' => { like =>'%'.lc( $name ).'%' },
 528                  ],
 529                 ],
 530                           } ,
 531                {  join =>  { 'stockprops' =>  'type'  }  ,
 532                   columns => [ qw/stock_id uniquename type_id organism_id / ],
 533                   distinct => 1
 534                }
 535             );
 536     }
 537     if( my $type = $c->req->param('stock_type') ) {
 538         $self->_validate_pair($c,'type_id',$type);
 539         $rs = $rs->search({ 'me.type_id' => $type });
 540     }
 541     if( my $organism = $c->req->param('organism') ) {
 542         $self->_validate_pair( $c, 'organism_id', $organism );
 543         $rs = $rs->search({ 'organism_id' => $organism });
 544     }
 545     if ( my $description = $c->req->param('description') ) {
 546         $self->_validate_pair($c, 'description');
 547         $rs = $rs->search( {
 548             -or => [
 549                  'lower(me.description)' => { like => '%'.lc( $description ).'%' } ,
 550                  'lower(stockprops.value)' => { like =>'%'.lc( $description ).'%' },
 551                 ],
 552                            } ,
 553                 {  join =>  { 'stockprops' =>  'type'  }  ,
 554                    columns => [ qw/stock_id uniquename type_id organism_id / ],
 555                    distinct => 1
 556                 }
 557             );
 558     }
 559     if ( my $editor = $c->req->param('person') ) {
 560         $self->_validate_pair( $c, 'person') ;
 561         $editor =~ s/,/ /g;
 562         $editor =~ s/\s+/ /g;
 563
 564         my $person_ids = $c->dbc->dbh->selectcol_arrayref(<<'', undef, $editor);
 565 SELECT sp_person_id FROM sgn_people.sp_person
 566     WHERE ( first_name || ' ' || last_name ) like '%' || ? || '%'
 567
 568         if (@$person_ids) {
 569             my $bindstr = join ',', map '?', @$person_ids;
 570             my $stock_ids =  $c->dbc->dbh->selectcol_arrayref(
 571                 "SELECT stock_id FROM phenome.stock_owner
 572     WHERE sp_person_id IN ($bindstr)",
 573                 undef,
 574                 @$person_ids,
 575                 );
 576             $rs = $rs->search({ 'me.stock_id' => { '-in' => $stock_ids } } );
 577          } else {
 578              $rs = $rs->search({ name => '' });
 579          }
 580     }
 581     if ( my $trait = $c->req->param('trait') ) {
 582         $rs = $rs->search( { 'observable.name' => $trait },
 583                      { join => { nd_experiment_stocks => { nd_experiment => {'nd_experiment_phenotypes' => {'phenotype' => 'observable' }}}},
 584                        columns => [ qw/stock_id uniquename type_id organism_id / ],
 585                        distinct => 1
 586                      } );
 587     }
 588     if ( my $min = $c->req->param('min_limit') ) {
 589         if ( $min =~ /^\d+$/ ) {
 590             $rs = $rs->search( { 'cast(phenotype.value as numeric) ' => { '>=' => $min }  },
 591                                { join => { nd_experiment_stocks => { nd_experiment => {'nd_experiment_phenotypes' => 'phenotype' }}},
 592                                  columns => [ qw/stock_id uniquename type_id organism_id / ],
 593                                  distinct => 1
 594                                } );
 595         }
 596     }
 597     if ( my $max = $c->req->param('max_limit') ) {
 598         if ( $max =~ /^\d+$/ ) {
 599             $rs = $rs->search( { 'cast(phenotype.value as numeric) ' => { '<=' => $max }  },
 600                                { join => { nd_experiment_stocks => { nd_experiment => {'nd_experiment_phenotypes' => 'phenotype' }}},
 601                                  columns => [ qw/stock_id uniquename type_id organism_id / ],
 602                                  distinct => 1
 603                                } );
 604         }
 605     }
 606     # this is for direct annotations in stock_cvterm
 607     if ( my $ontology = $c->req->param('onto') ) {
 608         my ($cv_name, $full_accession, $cvterm_name) = split(/--/ , $ontology);
 609         my ($db_name, $accession) = split(/:/, $full_accession);
 610         my $cvterm;
 611         my (@cvterm_ids, @children_ids);
 612         if ($db_name && $accession) {
 613             ($cvterm) = $self->schema->resultset("General::Db")->
 614                 search( { 'me.name' => $db_name })->
 615                 search_related('dbxrefs', { accession => $accession } )->
 616                 search_related('cvterm');
 617             @cvterm_ids = ( $cvterm->cvterm_id );
 618             @children_ids = $cvterm->recursive_children->get_column('cvterm_id')->all;
 619         } else {
 620             my $cvterms = $self->schema->resultset("Cv::Cvterm")->
 621                 search( { lc('name') => { 'LIKE' => lc($ontology) } });
 622             while ( my $term =  $cvterms->next ) {
 623                 push @cvterm_ids ,   $term->cvterm_id ;
 624                 push @children_ids , $term->recursive_children->get_column('cvterm_id')->all;
 625             }
 626         }
 627         push ( @children_ids, @cvterm_ids ) ;
 628         $rs = $rs->search( {
 629             'stock_cvterms.cvterm_id' => { -in =>  \@children_ids },
 630             -or => [
 631                 'stock_cvtermprops.value' => { '!=' => '1' },
 632                 'stock_cvtermprops.value' => undef,
 633                 ],
 634                 -or => [
 635                 lc('type.name')       => { 'NOT LIKE' => lc('obsolete') },
 636                 'type.name'           =>  undef,
 637                 ],
 638                            },
 639                            { join => { stock_cvterms => { 'stock_cvtermprops' => 'type' } },
 640                              columns => [ qw/stock_id uniquename type_id organism_id / ],
 641                              distinct => 1
 642                            } );
 643     }
 644     ###search for stocks involved in nd_experiments (phenotyping and genotyping)
 645     if ( my $project = $c->req->param('project') ) {
 646         $rs = $rs->search(
 647             {
 648                 'lower(project.name)' => { -like  => lc($project) },
 649             },
 650             { join => { nd_experiment_stocks => { nd_experiment => { 'nd_experiment_projects' => 'project' } } },
 651               columns => [ qw/stock_id uniquename type_id organism_id / ],
 652               distinct => 1
 653             } );
 654     }
 655     if ( my $location = $c->req->param('location') ) {
 656         $rs = $rs->search(
 657             {
 658                 'lower(nd_geolocation.description)' => { -like  => lc($location) },
 659             },
 660             { join => { nd_experiment_stocks => { nd_experiment => 'nd_geolocation' } },
 661               columns => [ qw/stock_id uniquename type_id organism_id / ],
 662               distinct => 1
 663             } );
 664     }
 665     if ( my $year = $c->req->param('year') ) {
 666         $rs = $rs->search(
 667             {
 668                 'lower(projectprops.value)' => { -like  => lc($year) },
 669             },
 670             { join => { nd_experiment_stocks => { nd_experiment => { 'nd_experiment_projects' => { 'project' => 'projectprops' } } } },
 671               columns => [ qw/stock_id uniquename type_id organism_id / ],
 672               distinct => 1
 673             } );
 674     }
 675
 676     #########
 677     ##########
 678     if ( my $has_image = $c->req->param('has_image') ) {
 679     }
 680     if ( my $has_locus = $c->req->param('has_locus') ) {
 681     }
 682     # page number and page size, and order by name
 683     $rs = $rs->search( undef, {
 684         page => $c->req->param('page')  || 1,
 685         rows => $c->req->param('page_size') || $self->default_page_size,
 686         order_by => 'uniquename',
 687                        });
 688     return $rs;
 689 }
 690
 691
 692 sub _stockprops {
 693     my ($self,$stock) = @_;
 694
 695     my $bcs_stock = $stock->get_object_row();
 696     my $properties ;
 697     if ($bcs_stock) {
 698         my $stockprops = $bcs_stock->search_related("stockprops");
 699         while ( my $prop =  $stockprops->next ) {
 700             push @{ $properties->{$prop->type->name} } ,   $prop->value ;
 701         }
 702     }
 703     return $properties;
 704 }
 705
 706
 707 sub _dbxrefs {
 708     my ($self,$stock) = @_;
 709     my $bcs_stock = $stock->get_object_row;
 710     my $dbxrefs ;
 711     if ($bcs_stock) {
 712         my $stock_dbxrefs = $bcs_stock->search_related("stock_dbxrefs");
 713         while ( my $sdbxref =  $stock_dbxrefs->next ) {
 714             my $url = $sdbxref->dbxref->db->urlprefix . $sdbxref->dbxref->db->url;
 715             my $accession = $sdbxref->dbxref->accession;
 716             $url = $url ? qq |<a href = "$url/$accession">$accession</a>| : $accession ;
 717             push @{ $dbxrefs->{$sdbxref->dbxref->db->name} } , $sdbxref->dbxref;
 718         }
 719     }
 720     return $dbxrefs;
 721 }
 722
 723 # this sub gets all phenotypes measured directly on this stock and
 724 # stores it in a hashref as { project_name => [ BCS::Phenotype::Phenotype, ... ]
 725
 726 sub _stock_project_phenotypes {
 727     my ($self, $bcs_stock) = @_;
 728
 729     return {} unless $bcs_stock;
 730     my $rs =  $self->schema->resultset("Stock::Stock")->stock_phenotypes_rs($bcs_stock);
 731     my %project_hashref;
 732     while ( my $r = $rs->next) {
 733         my $project_desc = $r->get_column('project_description');
 734         push @{ $project_hashref{ $project_desc }}, $r;
 735     }
 736     return \%project_hashref;
 737 }
 738
 739 # this sub gets all phenotypes measured on all subjects of this stock.
 740 # Subjects are in stock_relationship
 741 sub _stock_members_phenotypes {
 742     my ($self, $bcs_stock) = @_;
 743     return unless $bcs_stock;
 744     my %phenotypes;
 745     my ($has_members_genotypes) = $bcs_stock->result_source->schema->storage->dbh->selectrow_array( <<'', undef, $bcs_stock->stock_id );
 746 SELECT COUNT( DISTINCT genotype_id )
 747   FROM phenome.genotype
 748   JOIN stock subj using(stock_id)
 749   JOIN stock_relationship sr ON( sr.subject_id = subj.stock_id )
 750  WHERE sr.object_id = ?
 751
 752     # now we have rs of stock_relationship objects. We need to find
 753     # the phenotypes of their related subjects
 754     my $subjects = $bcs_stock->search_related('stock_relationship_objects')
 755                              ->search_related('subject');
 756     my $subject_phenotypes = $self->_stock_project_phenotypes($subjects );
 757     return ( $subject_phenotypes, $has_members_genotypes );
 758 }
 759
 760 ###########
 761 # this sub gets all genotypes measured directly on this stock and
 762 # stores it in a hashref as { project_name => [ BCS::Genotype::Genotype, ... ]
 763
 764 sub _stock_project_genotypes {
 765     my ($self, $bcs_stock) = @_;
 766     return {} unless $bcs_stock;
 767
 768     # hash of experiment_id => project(s) desc
 769     my %project_descriptions =
 770         map { $_->nd_experiment_id => join( ', ', map $_->project->description, $_->nd_experiment_projects ) }
 771         $bcs_stock->search_related('nd_experiment_stocks')
 772                   ->search_related('nd_experiment',
 773                                    {},
 774                                    { prefetch => { 'nd_experiment_projects' => 'project' } },
 775                                    );
 776     my $experiments = $bcs_stock->search_related('nd_experiment_stocks')
 777                                 ->search_related('nd_experiment',
 778                                                  {},
 779                                                  { prefetch => { nd_experiment_genotypes => 'genotype' } },
 780                                                 );
 781     my %genotypes;
 782     my $project_desc;
 783
 784     while (my $exp = $experiments->next) {
 785         # there should be one project linked to the experiment ?
 786         my @gen = map $_->genotype, $exp->nd_experiment_genotypes;
 787         $project_desc = $project_descriptions{ $exp->nd_experiment_id };
 788         #or die "no project found for exp ".$exp->nd_experiment_id;
 789
 790     #my @values;
 791         #foreach my $genotype (@gen) {
 792             #my $genotype_id = $genotype->genotype_id;
 793             #my $vals = $self->schema->storage->dbh->selectcol_arrayref
 794             #   ("SELECT value  FROM genotypeprop  WHERE genotype_id = ? ",
 795             #    undef,
 796             #    $genotype_id
 797             #   );
 798             #push @values, $vals->[0];
 799         #}
 800         push @{ $genotypes{ $project_desc }}, @gen if scalar(@gen);
 801     }
 802     return \%genotypes;
 803 }
 804
 805 ##############
 806
 807 sub _stock_dbxrefs {
 808     my ($self,$stock) = @_;
 809     my $bcs_stock = $stock->get_object_row;
 810     # hash of arrays. Keys are db names , values are lists of StockDbxref objects
 811     my $sdbxrefs ;
 812     if ($bcs_stock) {
 813         my $stock_dbxrefs = $bcs_stock->search_related("stock_dbxrefs");
 814         while ( my $sdbxref =  $stock_dbxrefs->next ) {
 815             push @{ $sdbxrefs->{$sdbxref->dbxref->db->name} } , $sdbxref;
 816         }
 817     }
 818     return $sdbxrefs;
 819 }
 820
 821 sub _stock_cvterms {
 822     my ($self,$stock, $c) = @_;
 823     my $bcs_stock = $stock->get_object_row;
 824     # hash of arrays. Keys are db names , values are lists of StockCvterm objects
 825     my $scvterms ;
 826     my $count;
 827     if ($bcs_stock) {
 828         my $stock_cvterms = $bcs_stock->search_related("stock_cvterms");
 829         while ( my $scvterm =  $stock_cvterms->next ) {
 830             $count++;
 831             push @{ $scvterms->{$scvterm->cvterm->dbxref->db->name} } , $scvterm;
 832         }
 833     }
 834     $c->stash->{ontology_count} = $count ;
 835     return $scvterms;
 836 }
 837
 838 # each stock may be linked with publications, each publication may have several dbxrefs
 839 sub _stock_pubs {
 840     my ($self, $stock) = @_;
 841     my $bcs_stock = $stock->get_object_row;
 842     my $pubs ;
 843     if ($bcs_stock) {
 844         my $stock_pubs = $bcs_stock->search_related("stock_pubs");
 845         while (my $spub = $stock_pubs->next ) {
 846             my $pub = $spub->pub;
 847             my $pub_dbxrefs = $pub->pub_dbxrefs;
 848             while (my $pub_dbxref = $pub_dbxrefs->next ) {
 849                 $pubs->{$pub_dbxref->dbxref->db->name . ":" .  $pub_dbxref->dbxref->accession } = $pub ;
 850             }
 851         }
 852     }
 853     return $pubs;
 854 }
 855
 856 # get all images. Optional: include those of subject stocks
 857 sub _stock_images {
 858     my ($self, $stock, $r) = @_;
 859     my $query = "select distinct image_id FROM phenome.stock_image WHERE stock_id = ?";
 860     $query .=  " OR stock_id IN (SELECT subject_id FROM stock_relationship WHERE object_id = ? )" if $r;
 861     my $ids = $r ?
 862         $stock->get_schema->storage->dbh->selectcol_arrayref
 863         ( $query,
 864           undef,
 865           $stock->get_stock_id,
 866           $stock->get_stock_id,
 867         ) :
 868         $stock->get_schema->storage->dbh->selectcol_arrayref
 869         ( $query,
 870           undef,
 871           $stock->get_stock_id,
 872         );
 873     return $ids;
 874 }
 875
 876
 877 sub _stock_allele_ids {
 878     my ($self, $stock) = @_;
 879     my $ids = $stock->get_schema->storage->dbh->selectcol_arrayref
 880         ( "SELECT allele_id FROM phenome.stock_allele WHERE stock_id=? ",
 881           undef,
 882           $stock->get_stock_id
 883         );
 884     return $ids;
 885 }
 886
 887 sub _stock_owner_ids {
 888     my ($self,$stock) = @_;
 889     my $ids = $stock->get_schema->storage->dbh->selectcol_arrayref
 890         ("SELECT sp_person_id FROM phenome.stock_owner WHERE stock_id = ? ",
 891          undef,
 892          $stock->get_stock_id
 893         );
 894     return $ids;
 895 }
 896
 897 sub _stock_has_pedigree {
 898   my ($self, $stock) = @_;
 899   my $bcs_stock = $stock->get_object_row;
 900   my $cvterm_female_parent = SGN::Model::Cvterm->get_cvterm_row($self->schema, 'female_parent', 'stock_relationship');
 901
 902   my $cvterm_male_parent = SGN::Model::Cvterm->get_cvterm_row($self->schema, 'male_parent', 'stock_relationship');
 903
 904   my $stock_relationships = $bcs_stock->search_related("stock_relationship_objects",undef,{ prefetch => ['type','subject'] });
 905   my $female_parent_relationship = $stock_relationships->find({type_id => $cvterm_female_parent->cvterm_id()});
 906   my $male_parent_relationship = $stock_relationships->find({type_id => $cvterm_male_parent->cvterm_id()});
 907   if ($female_parent_relationship || $male_parent_relationship) {
 908     return 1;
 909   } else {
 910     return 0;
 911   }
 912 }
 913
 914 sub _stock_has_descendants {
 915   my ($self, $stock) = @_;
 916   my $bcs_stock = $stock->get_object_row;
 917   my $cvterm_female_parent = SGN::Model::Cvterm->get_cvterm_row($self->schema,'female_parent', 'stock_relationship');
 918
 919   my $cvterm_male_parent = SGN::Model::Cvterm->get_cvterm_row($self->schema, 'male_parent', 'stock_relationship');
 920
 921   my $descendant_relationships = $bcs_stock->search_related("stock_relationship_subjects",undef,{ prefetch => ['type','object'] });
 922   if ($descendant_relationships) {
 923       return $descendant_relationships->count();
 924  # while (my $descendant_relationship = $descendant_relationships->next) {
 925  #      my $descendant_stock_id = $descendant_relationship->object_id();
 926  #      #if ($descendant_stock_id && (($descendant_relationship->type_id() == $cvterm_female_parent->cvterm_id()) || ($descendant_relationship->type_id() == $cvterm_male_parent->cvterm_id()))) {
 927  #      if ($descendant_stock_id) {
 928  #      return 1;
 929       } else {
 930         return 0;
 931       }
 932    # }
 933   #}
 934 }
 935
 936 sub _validate_pair {
 937     my ($self,$c,$key,$value) = @_;
 938     $c->throw( is_client_error => 1, public_message => "$value is not a valid value for $key" )
 939         if ($key =~ m/_id$/ and $value !~ m/\d+/);
 940 }
 941
 942
 943
 944
 945 __PACKAGE__->meta->make_immutable;