[Bio] / FigKernelPackages / Observation.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Observation.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.20, Wed Jun 27 22:14:01 2007 UTC revision 1.38, Mon Sep 10 15:10:04 2007 UTC
# Line 2  Line 2 
2    
3  use lib '/vol/ontologies';  use lib '/vol/ontologies';
4  use DBMaster;  use DBMaster;
5    use Data::Dumper;
6    
7  require Exporter;  require Exporter;
8  @EXPORT_OK = qw(get_objects);  @EXPORT_OK = qw(get_objects);
9    
10  use FIG_Config;  use FIG_Config;
11  use strict;  #use strict;
12  #use warnings;  #use warnings;
13  use HTML;  use HTML;
14    
# Line 26  Line 27 
27    
28  The data can be used to display information for a given sequence feature (protein or other, but primarily information is computed for proteins).  The data can be used to display information for a given sequence feature (protein or other, but primarily information is computed for proteins).
29    
 Example:  
   
   
 use FIG;  
 use Observation;  
   
 my $fig = new FIG;  
 my $fid = "fig|83333.1.peg.3";  
   
 my $observations = Observation::get_objects($fid);  
 foreach my $observation (@$observations) {  
     print "ID: " . $fid . "\n";  
     print "Start: " . $observation->start() . "\n";  
     ...  
 }  
   
 B<return an array of objects>  
   
   
 print "$Observation->acc\n" prints the Accession number if present for the Observation  
   
30  =cut  =cut
31    
32  =head1 BACKGROUND  =head1 BACKGROUND
# Line 70  Line 50 
50    
51  The public methods this package provides are listed below:  The public methods this package provides are listed below:
52    
 =head3 acc()  
53    
54  A valid accession or remote ID (in the style of a db_xref) or a valid local ID (FID) in case this is supported.  =head3 context()
55    
56    Returns close or diverse for purposes of displaying genomic context
57    
58  =cut  =cut
59    
60  sub acc {  sub context {
61    my ($self) = @_;    my ($self) = @_;
62    
63    return $self->{acc};    return $self->{context};
64  }  }
65    
66  =head3 description()  =head3 rows()
   
 The description of the hit. Taken from the data or from the our Ontology database for some cases e.g. IPR or PFAM.  
67    
68  B<Please note:>  each row in a displayed table
 Either remoteid or description is required.  
69    
70  =cut  =cut
71    
72  sub description {  sub rows {
73    my ($self) = @_;    my ($self) = @_;
74    
75    return $self->{description};    return $self->{rows};
76    }
77    
78    =head3 acc()
79    
80    A valid accession or remote ID (in the style of a db_xref) or a valid local ID (FID) in case this is supported.
81    
82    =cut
83    
84    sub acc {
85      my ($self) = @_;
86      return $self->{acc};
87  }  }
88    
89  =head3 class()  =head3 class()
# Line 163  Line 152 
152  sub type {  sub type {
153    my ($self) = @_;    my ($self) = @_;
154    
155    return $self->{acc};    return $self->{type};
156  }  }
157    
158  =head3 start()  =head3 start()
# Line 262  Line 251 
251      return $self->{hlength};      return $self->{hlength};
252  }  }
253    
   
   
254  =head3 evalue()  =head3 evalue()
255    
256  E-value or P-Value if present.  E-value or P-Value if present.
# Line 280  Line 267 
267    
268  Score if present.  Score if present.
269    
 B<Please note: >  
 Either score or eval are required.  
   
270  =cut  =cut
271    
272  sub score {  sub score {
# Line 290  Line 274 
274    return $self->{score};    return $self->{score};
275  }  }
276    
   
277  =head3 display()  =head3 display()
278    
279  will be different for each type  will be different for each type
# Line 303  Line 286 
286    
287  }  }
288    
289    =head3 display_table()
290    
291  =head3 rank()  will be different for each type
   
 Returns an integer from 1 - 10 indicating the importance of this observations.  
   
 Currently always returns 1.  
   
 =cut  
   
 sub rank {  
   my ($self) = @_;  
   
 #  return $self->{rank};  
   
   return 1;  
 }  
   
 =head3 supports_annotation()  
   
 Does a this observation support the annotation of its feature?  
   
 Returns  
   
 =over 3  
   
 =item 10, if feature annotation is identical to $self->description  
   
 =item 1, Feature annotation is similar to $self->annotation; this is computed using FIG::SameFunc()  
   
 =item undef  
   
 =back  
   
 =cut  
   
 sub supports_annotation {  
   my ($self) = @_;  
   
   # no code here so far  
   
   return $self->{supports_annotation};  
 }  
   
 =head3 url()  
   
 URL describing the subject. In case of a BLAST hit against a sequence, this URL will lead to a page displaying the sequence record for the sequence. In case of an HMM hit, the URL will be to the URL description.  
292    
293  =cut  =cut
294    
295  sub url {  sub display_table {
   my ($self) = @_;  
296    
297    my $url = get_url($self->type, $self->acc);    die "Abstract Table Method Called\n";
298    
   return $url;  
299  }  }
300    
301  =head3 get_objects()  =head3 get_objects()
302    
303  This is the B<REAL WORKHORSE> method of this Package.  This is the B<REAL WORKHORSE> method of this Package.
304    
 It will probably have to:  
   
 - get all sims for the feature  
 - get all bbhs for the feature  
 - copy information from sim to bbh (bbh have no match location etc)  
 - get pchs (difficult)  
 - get attributes (there is code for this that in get_attribute_based_observations  
 - get_attributes_based_observations returns an array of arrays of hashes like this"  
   
   my $dataset  
      [  
        [ { name => 'acc', value => '1234' },  
         { name => 'from', value => '4' },  
         { name => 'to', value => '400' },  
         ....  
        ],  
        [ { name => 'acc', value => '456' },  
         { name => 'from', value => '1' },  
         { name => 'to', value => '100' },  
         ....  
        ],  
        ...  
      ];  
    return $datasets;  
  }  
   
 It will invoke the required calls to the SEED API to retrieve the information required.  
   
305  =cut  =cut
306    
307  sub get_objects {  sub get_objects {
308      my ($self,$fid,$classes) = @_;      my ($self,$fid,$scope) = @_;
309    
310      my $objects = [];      my $objects = [];
311      my @matched_datasets=();      my @matched_datasets=();
312        my $fig = new FIG;
313    
314      # call function that fetches attribute based observations      # call function that fetches attribute based observations
315      # returns an array of arrays of hashes      # returns an array of arrays of hashes
316    
317      if(scalar(@$classes) < 1){      if($scope){
318          get_attribute_based_observations($fid,\@matched_datasets);          get_cluster_observations($fid,\@matched_datasets,$scope);
         get_sims_observations($fid,\@matched_datasets);  
         get_identical_proteins($fid,\@matched_datasets);  
         get_functional_coupling($fid,\@matched_datasets);  
319      }      }
320      else{      else{
321          my %domain_classes;          my %domain_classes;
322          my $identical_flag=0;          my @attributes = $fig->get_attributes($fid);
323          my $pch_flag=0;          $domain_classes{'CDD'} = 1;
         my $location_flag = 0;  
         my $sims_flag=0;  
         my $cluster_flag = 0;  
         my $pdb_flag = 0;  
         foreach my $class (@$classes){  
             if($class =~ /(IPR|CDD|PFAM)/){  
                 $domain_classes{$class} = 1;  
             }  
             elsif ($class eq "IDENTICAL")  
             {  
                 $identical_flag = 1;  
             }  
             elsif ($class eq "PCH")  
             {  
                 $pch_flag = 1;  
             }  
             elsif ($class =~/(SIGNALP_CELLO_TMPRED)/)  
             {  
                 $location_flag = 1;  
             }  
             elsif ($class eq "SIM")  
             {  
                 $sims_flag = 1;  
             }  
             elsif ($class eq "CLUSTER")  
             {  
                 $cluster_flag = 1;  
             }  
             elsif ($class eq "PDB")  
             {  
                 $pdb_flag = 1;  
             }  
   
         }  
   
         if ($identical_flag ==1)  
         {  
324              get_identical_proteins($fid,\@matched_datasets);              get_identical_proteins($fid,\@matched_datasets);
325          }          get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets,\@attributes);
         if ( (defined($domain_classes{IPR})) || (defined($domain_classes{CDD})) || (defined($domain_classes{PFAM})) ) {  
             get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets);  
         }  
         if ($pch_flag == 1)  
         {  
             get_functional_coupling($fid,\@matched_datasets);  
         }  
         if ($sims_flag == 1)  
         {  
326              get_sims_observations($fid,\@matched_datasets);              get_sims_observations($fid,\@matched_datasets);
327          }          get_functional_coupling($fid,\@matched_datasets);
328            get_attribute_based_location_observations($fid,\@matched_datasets,\@attributes);
329          if ($location_flag == 1)          get_pdb_observations($fid,\@matched_datasets,\@attributes);
         {  
             get_attribute_based_location_observations($fid,\@matched_datasets);  
         }  
         if ($cluster_flag == 1)  
         {  
             get_cluster_observations($fid,\@matched_datasets);  
         }  
         if ($pdb_flag == 1)  
         {  
             get_pdb_observations($fid,\@matched_datasets);  
         }  
   
   
330      }      }
331    
332      foreach my $dataset (@matched_datasets) {      foreach my $dataset (@matched_datasets) {
# Line 511  Line 360 
360    
361  }  }
362    
363  =head1 Internal Methods  =head3 display_housekeeping
364    This method returns the housekeeping data for a given peg in a table format
 These methods are not meant to be used outside of this package.  
   
 B<Please do not use them outside of this package!>  
365    
366  =cut  =cut
367    sub display_housekeeping {
368        my ($self,$fid) = @_;
369        my $fig = new FIG;
370        my $content;
371    
372        my $org_name = $fig->org_of($fid);
373        my $org_id   = $fig->orgid_of_orgname($org_name);
374        my $loc      = $fig->feature_location($fid);
375        my($contig, $beg, $end) = $fig->boundaries_of($loc);
376        my $strand   = ($beg <= $end)? '+' : '-';
377        my @subsystems = $fig->subsystems_for_peg($fid);
378        my $function = $fig->function_of($fid);
379        my @aliases  = $fig->feature_aliases($fid);
380        my $taxonomy = $fig->taxonomy_of($org_id);
381        my @ecs = ($function =~ /\(EC\s(\d+\.[-\d+]+\.[-\d+]+\.[-\d+]+)\)/g);
382    
383        $content .= qq(<b>General Protein Data</b><br><br><br><table border="0">);
384        $content .= qq(<tr width=15%><td >FIG ID</td><td>$fid</td></tr>\n);
385        $content .= qq(<tr width=15%><td >Organism Name</td><td>$org_name,&nbsp;&nbsp;$org_id</td></tr>\n);
386        $content .= qq(<tr><td width=15%>Taxonomy</td><td>$taxonomy</td></tr>\n);
387        $content .= qq(<tr width=15%><td>FIG Organism ID</td><td>$org_id</td></tr>\n);
388        $content .= qq(<tr width=15%><td>Gene Location</td><td>Contig $contig [$beg,$end], Strand $strand</td></tr>\n);;
389        $content .= qq(<tr width=15%><td>Function</td><td>$function</td></tr>\n);
390        if ( @ecs ) {
391            $content .= qq(<tr><td>EC:</td><td>);
392            foreach my $ec ( @ecs ) {
393                my $ec_name = $fig->ec_name($ec);
394                $content .= join(" -- ", $ec, $ec_name) . "<br>\n";
395            }
396            $content .= qq(</td></tr>\n);
397        }
398    
399  =head3 get_url (internal)      if ( @subsystems ) {
400            $content .= qq(<tr><td>Subsystems</td><td>);
401  get_url() return a valid URL or undef for any observation.          foreach my $subsystem ( @subsystems ) {
402                $content .= join(" -- ", @$subsystem) . "<br>\n";
403  URLs are constructed by looking at the Accession acc()  and  name()          }
404        }
405    
406  Info from both attributes is combined with a table of base URLs stored in this function.      my %groups;
407        if ( @aliases ) {
408            # get the db for each alias
409            foreach my $alias (@aliases){
410                $groups{$alias} = &get_database($alias);
411            }
412    
413  =cut          # group ids by aliases
414            my %db_aliases;
415            foreach my $key (sort {$groups{$a} cmp $groups{$b}} keys %groups){
416                push (@{$db_aliases{$groups{$key}}}, $key);
417            }
418    
 sub get_url {  
419    
420   my ($self) = @_;          $content .= qq(<tr><td>Aliases</td><td><table border="0">);
421   my $url='';          foreach my $key (sort keys %db_aliases){
422                $content .= qq(<tr><td>$key:</td><td>) . join(", ", @{$db_aliases{$key}}) . qq(</td></tr\n);
423            }
424            $content .= qq(</td></tr></table>\n);
425        }
426    
427  # a hash with a URL for each observation; identified by name()      $content .= qq(</table><p>\n);
 #my $URL             => { 'PFAM' => "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?" ,\  
 #                       'IPR'    => "http://www.ebi.ac.uk/interpro/DisplayIproEntry?ac=" ,\  
 #                          'CDD' => "http://www.ncbi.nlm.nih.gov/Structure/cdd/cddsrv.cgi?uid=",\  
 #                       'PIR'    => "http://www.ncbi.nlm.nih.gov/Structure/cdd/cddsrv.cgi?uid=",\  
 #                       'FIGFAM' => '',\  
 #                          'sim'=> "http://www.theseed.org/linkin.cgi?id=",\  
 #                          'bbh'=> "http://www.theseed.org/linkin.cgi?id="  
 #};  
428    
429  # if (defined $URL{$self->name}) {      return ($content);
 #     $url = $URL{$self->name}.$self->acc;  
 #     return $url;  
 # }  
 # else  
      return undef;  
430  }  }
431    
432  =head3 get_display_method (internal)  =head3 get_sims_summary
433    This method uses as input the similarities of a peg and creates a tree view of their taxonomy
434    
435  get_display_method() return a valid URL or undef for any observation.  =cut
436    
437  URLs are constructed by looking at the Accession acc()  and  name()  sub get_sims_summary {
438  and Info from both attributes is combined with a table of base URLs stored in this function.      my ($observation, $fid) = @_;
439        my $fig = new FIG;
440        my %families;
441        my @sims= $fig->nsims($fid,20000,10,"fig");
442    
443  =cut      foreach my $sim (@sims){
444            next if ($sim->[1] !~ /fig\|/);
445            my $genome = $fig->genome_of($sim->[1]);
446            my $taxonomy = $fig->taxonomy_of($fig->genome_of($sim->[1]));
447            my $parent_tax = "Root";
448            my @currLineage = ($parent_tax);
449            foreach my $tax (split(/\; /, $taxonomy)){
450                push (@{$families{children}{$parent_tax}}, $tax);
451                push (@currLineage, $tax);
452                $families{parent}{$tax} = $parent_tax;
453                $families{lineage}{$tax} = join(";", @currLineage);
454                $parent_tax = $tax;
455            }
456        }
457    
458  sub get_display_method {      foreach my $key (keys %{$families{children}}){
459            $families{count}{$key} = @{$families{children}{$key}};
460    
461            my %saw;
462            my @out = grep(!$saw{$_}++, @{$families{children}{$key}});
463            $families{children}{$key} = \@out;
464        }
465        return (\%families);
466    }
467    
468   my ($self) = @_;  =head1 Internal Methods
469    
470  # a hash with a URL for each observation; identified by name()  These methods are not meant to be used outside of this package.
 #my $URL             => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\  
 #                        'bbh'=> "http://www.theseed.org/featalign.cgi?id1="  
 # };  
471    
472  #if (defined $URL{$self->name}) {  B<Please do not use them outside of this package!>
 #     $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc;  
 #     return $url;  
 # }  
 # else  
      return undef;  
 }  
473    
474    =cut
475    
476  sub get_attribute_based_domain_observations{  sub get_attribute_based_domain_observations{
477    
478      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)
479      my ($fid,$domain_classes,$datasets_ref) = (@_);      my ($fid,$domain_classes,$datasets_ref,$attributes_ref) = (@_);
480    
481      my $fig = new FIG;      my $fig = new FIG;
482    
483      foreach my $attr_ref ($fig->get_attributes($fid)) {      foreach my $attr_ref (@$attributes_ref) {
484    #    foreach my $attr_ref ($fig->get_attributes($fid)) {
485          my $key = @$attr_ref[1];          my $key = @$attr_ref[1];
486          my @parts = split("::",$key);          my @parts = split("::",$key);
487          my $class = $parts[0];          my $class = $parts[0];
# Line 613  Line 507 
507                                 'type' => "dom" ,                                 'type' => "dom" ,
508                                 'evalue' => $evalue,                                 'evalue' => $evalue,
509                                 'start' => $from,                                 'start' => $from,
510                                 'stop' => $to                                 'stop' => $to,
511                                   'fig_id' => $fid,
512                                   'score' => $raw_evalue
513                                 };                                 };
514    
515                  push (@{$datasets_ref} ,$dataset);                  push (@{$datasets_ref} ,$dataset);
# Line 624  Line 520 
520    
521  sub get_attribute_based_location_observations{  sub get_attribute_based_location_observations{
522    
523      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref, $attributes_ref) = (@_);
524      my $fig = new FIG;      my $fig = new FIG;
525    
526      my $location_attributes = ['SignalP','CELLO','TMPRED'];      my $location_attributes = ['SignalP','CELLO','TMPRED','Phobius'];
527    
528        my $dataset = {'type' => "loc",
529                       'class' => 'SIGNALP_CELLO_TMPRED',
530                       'fig_id' => $fid
531                       };
532    
533      my $dataset = {'type' => "loc", 'class' => 'SIGNALP_CELLO_TMPRED'};      foreach my $attr_ref (@$attributes_ref){
534      foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) {  #    foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) {
535          my $key = @$attr_ref[1];          my $key = @$attr_ref[1];
536            next if (($key !~ /SignalP/) && ($key !~ /CELLO/) && ($key !~ /TMPRED/)  && ($key !~/Phobius/) );
537          my @parts = split("::",$key);          my @parts = split("::",$key);
538          my $sub_class = $parts[0];          my $sub_class = $parts[0];
539          my $sub_key = $parts[1];          my $sub_key = $parts[1];
# Line 641  Line 543 
543                  my @value_parts = split(";",$value);                  my @value_parts = split(";",$value);
544                  $dataset->{'cleavage_prob'} = $value_parts[0];                  $dataset->{'cleavage_prob'} = $value_parts[0];
545                  $dataset->{'cleavage_loc'} = $value_parts[1];                  $dataset->{'cleavage_loc'} = $value_parts[1];
546    #               print STDERR "LOC: $value_parts[1]";
547              }              }
548              elsif($sub_key eq "signal_peptide"){              elsif($sub_key eq "signal_peptide"){
549                  $dataset->{'signal_peptide_score'} = $value;                  $dataset->{'signal_peptide_score'} = $value;
550              }              }
551          }          }
552    
553          elsif($sub_class eq "CELLO"){          elsif($sub_class eq "CELLO"){
554              $dataset->{'cello_location'} = $sub_key;              $dataset->{'cello_location'} = $sub_key;
555              $dataset->{'cello_score'} = $value;              $dataset->{'cello_score'} = $value;
556          }          }
         elsif($sub_class eq "TMPRED"){  
             my @value_parts = split(";",$value);  
             $dataset->{'tmpred_score'} = $value_parts[0];  
             $dataset->{'tmpred_locations'} = $value_parts[1];  
         }  
     }  
   
     push (@{$datasets_ref} ,$dataset);  
557    
558            elsif($sub_class eq "Phobius"){
559                if($sub_key eq "transmembrane"){
560                    $dataset->{'phobius_tm_locations'} = $value;
561                }
562                elsif($sub_key eq "signal"){
563                    $dataset->{'phobius_signal_location'} = $value;
564  }  }
   
   
 =head3 get_attribute_based_evidence (internal)  
   
 This method retrieves evidence from the attribute server  
   
 =cut  
   
 sub get_attribute_based_observations{  
   
     # we read a FIG ID and a reference to an array (of arrays of hashes, see above)  
     my ($fid,$datasets_ref) = (@_);  
   
     my $_myfig = new FIG;  
   
     foreach my $attr_ref ($_myfig->get_attributes($fid)) {  
   
         # convert the ref into a string for easier handling  
         my ($string) = "@$attr_ref";  
   
 #       print "S:$string\n";  
         my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/);  
   
         # THIS SHOULD BE DONE ANOTHER WAY FM->TD  
         # we need to do the right thing for each type, ie no evalue for CELLO and no coordinates, but a score, etc  
         # as fas as possible this should be configured so that the type of observation and the regexp are  
         # stored somewhere for easy expansion  
         #  
   
         if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) {  
   
             # some keys are composite CDD::1233244 or PFAM:PF1233  
   
             if ( $key =~ /::/ ) {  
                 my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/);  
                 $val=$restkey.";".$val;  
                 $key=$firstkey;  
565              }              }
566    
567              my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ );          elsif($sub_class eq "TMPRED"){
568                my @value_parts = split(/\;/,$value);
569              my $evalue= 255;              $dataset->{'tmpred_score'} = $value_parts[0];
570              if (defined $raw_evalue) { # some of the tool do not give us an evalue              $dataset->{'tmpred_locations'} = $value_parts[1];
   
                 my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/);  
                 my ($new_k, $new_exp);  
   
                 #  
                 #  THIS DOES NOT WORK PROPERLY  
                 #  
                 if($raw_evalue =~/(\d+).(\d+)/){  
   
 #                   $new_exp = (1000+$expo);  
         #           $new_k = $k / 100;  
   
571                  }                  }
                 $evalue = "0.01"#new_k."e-".$new_exp;  
572              }              }
573    
             # unroll it all into an array of hashes  
             # this needs to be done differently for different types of observations  
             my $dataset = [ { name => 'class', value => $key },  
                             { name => 'acc' , value => $acc},  
                             { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD  
                             { name => 'evalue', value => $evalue },  
                             { name => 'start', value => $from},  
                             { name => 'stop' , value => $to}  
                             ];  
   
574              push (@{$datasets_ref} ,$dataset);              push (@{$datasets_ref} ,$dataset);
575          }  
     }  
576  }  }
577    
578  =head3 get_pdb_observations() (internal)  =head3 get_pdb_observations() (internal)
# Line 741  Line 582 
582  =cut  =cut
583    
584  sub get_pdb_observations{  sub get_pdb_observations{
585      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref, $attributes_ref) = (@_);
586    
587      my $fig = new FIG;      my $fig = new FIG;
588    
589      print STDERR "get pdb obs called\n";      foreach my $attr_ref (@$attributes_ref){
590      foreach my $attr_ref ($fig->get_attributes($fid,'PDB')) {      #foreach my $attr_ref ($fig->get_attributes($fid,'PDB')) {
591    
592          my $key = @$attr_ref[1];          my $key = @$attr_ref[1];
593            next if ( ($key !~ /PDB/));
594          my($key1,$key2) =split("::",$key);          my($key1,$key2) =split("::",$key);
595          my $value = @$attr_ref[2];          my $value = @$attr_ref[2];
596          my ($evalue,$location) = split(";",$value);          my ($evalue,$location) = split(";",$value);
# Line 767  Line 609 
609                         'acc' => $key2,                         'acc' => $key2,
610                         'evalue' => $evalue,                         'evalue' => $evalue,
611                         'start' => $start,                         'start' => $start,
612                         'stop' => $stop                         'stop' => $stop,
613                           'fig_id' => $fid
614                         };                         };
615    
616          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
617      }      }
   
618  }  }
619    
   
   
   
620  =head3 get_cluster_observations() (internal)  =head3 get_cluster_observations() (internal)
621    
622  This methods sets the type and class for cluster observations  This methods sets the type and class for cluster observations
# Line 785  Line 624 
624  =cut  =cut
625    
626  sub get_cluster_observations{  sub get_cluster_observations{
627      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref,$scope) = (@_);
628    
629      my $dataset = {'class' => 'CLUSTER',      my $dataset = {'class' => 'CLUSTER',
630                     'type' => 'fc'                     'type' => 'fc',
631                       'context' => $scope,
632                       'fig_id' => $fid
633                     };                     };
634      push (@{$datasets_ref} ,$dataset);      push (@{$datasets_ref} ,$dataset);
635  }  }
# Line 804  Line 645 
645    
646      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
647      my $fig = new FIG;      my $fig = new FIG;
648  #    my @sims= $fig->nsims($fid,100,1e-20,"fig");      my @sims= $fig->nsims($fid,500,10,"fig");
     my @sims= $fig->nsims($fid,100,1e-20,"all");  
649      my ($dataset);      my ($dataset);
650    
651        my %id_list;
652        foreach my $sim (@sims){
653            my $hit = $sim->[1];
654    
655            next if ($hit !~ /^fig\|/);
656            my @aliases = $fig->feature_aliases($hit);
657            foreach my $alias (@aliases){
658                $id_list{$alias} = 1;
659            }
660        }
661    
662        my %already;
663        my (@new_sims, @uniprot);
664      foreach my $sim (@sims){      foreach my $sim (@sims){
665          my $hit = $sim->[1];          my $hit = $sim->[1];
666            my ($id) = ($hit) =~ /\|(.*)/;
667            next if (defined($already{$id}));
668            next if (defined($id_list{$hit}));
669            push (@new_sims, $sim);
670            $already{$id} = 1;
671        }
672    
673        foreach my $sim (@new_sims){
674            my $hit = $sim->[1];
675          my $percent = $sim->[2];          my $percent = $sim->[2];
676          my $evalue = $sim->[10];          my $evalue = $sim->[10];
677          my $qfrom = $sim->[6];          my $qfrom = $sim->[6];
# Line 834  Line 697 
697                      'organism' => $organism,                      'organism' => $organism,
698                      'function' => $func,                      'function' => $func,
699                      'qlength' => $qlength,                      'qlength' => $qlength,
700                      'hlength' => $hlength                      'hlength' => $hlength,
701                        'fig_id' => $fid
702                      };                      };
703    
704          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
# Line 857  Line 721 
721      elsif ($id =~ /^uni\|/)           { $db = "UniProt" }      elsif ($id =~ /^uni\|/)           { $db = "UniProt" }
722      elsif ($id =~ /^tigr\|/)          { $db = "TIGR" }      elsif ($id =~ /^tigr\|/)          { $db = "TIGR" }
723      elsif ($id =~ /^pir\|/)           { $db = "PIR" }      elsif ($id =~ /^pir\|/)           { $db = "PIR" }
724      elsif ($id =~ /^kegg\|/)          { $db = "KEGG" }      elsif (($id =~ /^kegg\|/) || ($id =~ /Spy/))    { $db = "KEGG" }
725      elsif ($id =~ /^tr\|/)            { $db = "TrEMBL" }      elsif ($id =~ /^tr\|/)            { $db = "TrEMBL" }
726      elsif ($id =~ /^eric\|/)          { $db = "ASAP" }      elsif ($id =~ /^eric\|/)          { $db = "ASAP" }
727      elsif ($id =~ /^img\|/)           { $db = "JGI" }      elsif ($id =~ /^img\|/)           { $db = "JGI" }
# Line 866  Line 730 
730    
731  }  }
732    
733    
734  =head3 get_identical_proteins() (internal)  =head3 get_identical_proteins() (internal)
735    
736  This methods retrieves sims fills the internal data structures.  This methods retrieves sims fills the internal data structures.
# Line 876  Line 741 
741    
742      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
743      my $fig = new FIG;      my $fig = new FIG;
744      my @funcs = ();      my $funcs_ref;
745    
746    #    my %id_list;
747      my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);      my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);
748    #    my @aliases = $fig->feature_aliases($fid);
749    #    foreach my $alias (@aliases){
750    #       $id_list{$alias} = 1;
751    #    }
752    
753      foreach my $id (@maps_to) {      foreach my $id (@maps_to) {
754          my ($tmp, $who);          my ($tmp, $who);
755          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {
756    #        if (($id ne $fid) && ($tmp = $fig->function_of($id)) && (! defined ($id_list{$id}))) {
757              $who = &get_database($id);              $who = &get_database($id);
758              push(@funcs, [$id,$who,$tmp]);              push(@$funcs_ref, [$id,$who,$tmp]);
759          }          }
760      }      }
761    
762      my ($dataset);      my ($dataset);
     foreach my $row (@funcs){  
         my $id = $row->[0];  
         my $organism = $fig->org_of($fid);  
         my $who = $row->[1];  
         my $assignment = $row->[2];  
   
763          my $dataset = {'class' => 'IDENTICAL',          my $dataset = {'class' => 'IDENTICAL',
                        'id' => $id,  
                        'organism' => $organism,  
764                         'type' => 'seq',                         'type' => 'seq',
765                         'database' => $who,                     'fig_id' => $fid,
766                         'function' => $assignment                     'rows' => $funcs_ref
767                         };                         };
768    
769          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
770      }  
771    
772  }  }
773    
# Line 935  Line 798 
798                    } @fc_data;                    } @fc_data;
799    
800      my ($dataset);      my ($dataset);
     foreach my $row (@rows){  
         my $id = $row->[1];  
         my $score = $row->[0];  
         my $description = $row->[2];  
801          my $dataset = {'class' => 'PCH',          my $dataset = {'class' => 'PCH',
                        'score' => $score,  
                        'id' => $id,  
802                         'type' => 'fc',                         'type' => 'fc',
803                         'function' => $description                     'fig_id' => $fid,
804                       'rows' => \@rows
805                         };                         };
806    
807          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
     }  
 }  
   
 =head3 get_sims_and_bbhs() (internal)  
   
 This methods retrieves sims and also BBHs and fills the internal data structures.  
   
 =cut  
   
 #     sub get_sims_and_bbhs{  
   
 #       # blast m8 output format  
 #       # id1, id2, %ident, align len, mismatches, gaps, q.start, q.stop, s. start, s.stop, eval, bit  
   
 #       my $Sims=();  
 #       @sims_src = $fig->sims($fid,80,500,"fig",0);  
 #       print "found $#sims_src SIMs\n";  
 #       foreach $sims (@sims_src) {  
 #           my ($sims_string) = "@$sims";  
 # #       print "$sims_string\n";  
 #           my ($rfid,$start,$stop,$eval) = ( $sims_string =~ /\S+\s+(\S+)\s+\S+\s\S+\s+(\S+)\s+(\S+)\s+  
 #                                             \S+\s+\S+\s+\S+\s+\S+\s+(\S+)+.*/);  
 # #       print "ID: $rfid, E:$eval, Start:$start stop:$stop\n";  
 #           $Sims{$rfid}{'eval'}=$eval;  
 #           $Sims{$rfid}{'start'}=$start;  
 #           $Sims{$rfid}{'stop'}=$stop;  
 #           print "$rfid $Sims{$rfid}{'eval'}\n";  
 #       }  
   
 #       # BBHs  
 #       my $BBHs=();  
   
 #       @bbhs_src = $fig->bbhs($fid,1.0e-10);  
 #       print "found $#bbhs_src BBHs\n";  
 #       foreach $bbh (@bbhs_src) {  
 #           #print "@$bbh\n";  
 #           my ($bbh_string) = "@$bbh";  
 #           my ($rfid,$eval,$score) = ( $bbh_string =~ /(\S+)\s(\S+)\s(\S+)/);  
 #           #print "ID: $rfid, E:$eval, S:$score\n";  
 #           $BBHs{$rfid}{'eval'}=$eval;  
 #           $BBHs{$rfid}{'score'}=$score;  
 # #print "$rfid $BBHs{$rfid}{'eval'}\n";  
 #       }  
   
 #     }  
   
808    
809    }
810    
811  =head3 new (internal)  =head3 new (internal)
812    
# Line 1004  Line 817 
817  sub new {  sub new {
818    my ($class,$dataset) = @_;    my ($class,$dataset) = @_;
819    
   
   #$self = { acc => '',  
 #           description => '',  
 #           class => '',  
 #           type => '',  
 #           start => '',  
 #           stop => '',  
 #           evalue => '',  
 #           score => '',  
 #           display_method => '',  
 #           feature_id => '',  
 #           rank => '',  
 #           supports_annotation => '',  
 #           id => '',  
 #            organism => '',  
 #            who => ''  
 #         };  
   
820    my $self = { class => $dataset->{'class'},    my $self = { class => $dataset->{'class'},
821                 type => $dataset->{'type'}                 type => $dataset->{'type'},
822                   fig_id => $dataset->{'fig_id'},
823                   score => $dataset->{'score'},
824             };             };
825    
826    bless($self,$class);    bless($self,$class);
# Line 1043  Line 840 
840      return $self->{identity};      return $self->{identity};
841  }  }
842    
843    =head3 fig_id (internal)
844    
845    =cut
846    
847    sub fig_id {
848      my ($self) = @_;
849      return $self->{fig_id};
850    }
851    
852  =head3 feature_id (internal)  =head3 feature_id (internal)
853    
854    
# Line 1102  Line 908 
908      return $self->{database};      return $self->{database};
909  }  }
910    
911    sub score {
912      my ($self) = @_;
913    
914      return $self->{score};
915    }
916    
917  ############################################################  ############################################################
918  ############################################################  ############################################################
919  package Observation::PDB;  package Observation::PDB;
# Line 1127  Line 939 
939  =cut  =cut
940    
941  sub display{  sub display{
942      my ($self,$gd,$fid) = @_;      my ($self,$gd) = @_;
943    
944        my $fid = $self->fig_id;
945      my $dbmaster = DBMaster->new(-database =>'Ontology');      my $dbmaster = DBMaster->new(-database =>'Ontology');
946    
     print STDERR "PDB::display called\n";  
   
947      my $acc = $self->acc;      my $acc = $self->acc;
948    
     print STDERR "acc:$acc\n";  
949      my ($pdb_description,$pdb_source,$pdb_ligand);      my ($pdb_description,$pdb_source,$pdb_ligand);
950      my $pdb_objs = $dbmaster->pdb->get_objects( { 'id' => $acc } );      my $pdb_objs = $dbmaster->pdb->get_objects( { 'id' => $acc } );
951      if(!scalar(@$pdb_objs)){      if(!scalar(@$pdb_objs)){
# Line 1238  Line 1048 
1048    
1049      my ($class,$dataset) = @_;      my ($class,$dataset) = @_;
1050      my $self = $class->SUPER::new($dataset);      my $self = $class->SUPER::new($dataset);
1051      $self->{id} = $dataset->{'id'};      $self->{rows} = $dataset->{'rows'};
     $self->{organism} = $dataset->{'organism'};  
     $self->{function} = $dataset->{'function'};  
     $self->{database} = $dataset->{'database'};  
1052    
1053      bless($self,$class);      bless($self,$class);
1054      return $self;      return $self;
1055  }  }
1056    
1057  =head3 display()  =head3 display_table()
1058    
1059  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
1060  This code will display a table for the identical protein  This code will display a table for the identical protein
# Line 1258  Line 1065 
1065    
1066  =cut  =cut
1067    
 sub display{  
     my ($self, $cgi, $dataset) = @_;  
1068    
1069    sub display_table{
1070        my ($self) = @_;
1071    
1072        my $fig = new FIG;
1073        my $fid = $self->fig_id;
1074        my $rows = $self->rows;
1075        my $cgi = new CGI;
1076      my $all_domains = [];      my $all_domains = [];
1077      my $count_identical = 0;      my $count_identical = 0;
1078      my $content;      my $content;
1079      foreach my $thing (@$dataset) {      foreach my $row (@$rows) {
1080          next if ($thing->class ne "IDENTICAL");          my $id = $row->[0];
1081            my $who = $row->[1];
1082            my $assignment = $row->[2];
1083            my $organism = $fig->org_of($id);
1084          my $single_domain = [];          my $single_domain = [];
1085          push(@$single_domain,$thing->database);          push(@$single_domain,$who);
         my $id = $thing->id;  
         $count_identical++;  
1086          push(@$single_domain,&HTML::set_prot_links($cgi,$id));          push(@$single_domain,&HTML::set_prot_links($cgi,$id));
1087          push(@$single_domain,$thing->organism);          push(@$single_domain,$organism);
1088          #push(@$single_domain,$thing->type);          push(@$single_domain,$assignment);
         push(@$single_domain,$thing->function);  
1089          push(@$all_domains,$single_domain);          push(@$all_domains,$single_domain);
1090            $count_identical++;
1091      }      }
1092    
1093      if ($count_identical >0){      if ($count_identical >0){
# Line 1288  Line 1101 
1101    
1102  1;  1;
1103    
   
1104  #########################################  #########################################
1105  #########################################  #########################################
1106  package Observation::FC;  package Observation::FC;
# Line 1300  Line 1112 
1112    
1113      my ($class,$dataset) = @_;      my ($class,$dataset) = @_;
1114      my $self = $class->SUPER::new($dataset);      my $self = $class->SUPER::new($dataset);
1115      $self->{score} = $dataset->{'score'};      $self->{rows} = $dataset->{'rows'};
     $self->{id} = $dataset->{'id'};  
     $self->{function} = $dataset->{'function'};  
1116    
1117      bless($self,$class);      bless($self,$class);
1118      return $self;      return $self;
1119  }  }
1120    
1121  =head3 display()  =head3 display_table()
1122    
1123  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
1124  This code will display a table for the identical protein  This code will display a table for the identical protein
# Line 1319  Line 1129 
1129    
1130  =cut  =cut
1131    
1132  sub display {  sub display_table {
     my ($self,$cgi,$dataset, $fid) = @_;  
1133    
1134        my ($self,$dataset) = @_;
1135        my $fid = $self->fig_id;
1136        my $rows = $self->rows;
1137        my $cgi = new CGI;
1138      my $functional_data = [];      my $functional_data = [];
1139      my $count = 0;      my $count = 0;
1140      my $content;      my $content;
1141    
1142      foreach my $thing (@$dataset) {      foreach my $row (@$rows) {
1143          my $single_domain = [];          my $single_domain = [];
         next if ($thing->class ne "PCH");  
1144          $count++;          $count++;
1145    
1146          # construct the score link          # construct the score link
1147          my $score = $thing->score;          my $score = $row->[0];
1148          my $toid = $thing->id;          my $toid = $row->[1];
1149          my $link = $cgi->url(-relative => 1) . "?user=master&request=show_coupling_evidence&prot=$fid&to=$toid&SPROUT=";          my $link = $cgi->url(-relative => 1) . "?user=master&request=show_coupling_evidence&prot=$fid&to=$toid&SPROUT=";
1150          my $sc_link = "<a href=$link>$score</a>";          my $sc_link = "<a href=$link>$score</a>";
1151    
1152          push(@$single_domain,$sc_link);          push(@$single_domain,$sc_link);
1153          push(@$single_domain,$thing->id);          push(@$single_domain,$row->[1]);
1154          push(@$single_domain,$thing->function);          push(@$single_domain,$row->[2]);
1155          push(@$functional_data,$single_domain);          push(@$functional_data,$single_domain);
1156      }      }
1157    
# Line 1376  Line 1188 
1188  sub display {  sub display {
1189      my ($thing,$gd) = @_;      my ($thing,$gd) = @_;
1190      my $lines = [];      my $lines = [];
1191      my $line_config = { 'title' => $thing->acc,  #    my $line_config = { 'title' => $thing->acc,
1192                          'short_title' => $thing->type,  #                       'short_title' => $thing->type,
1193                          'basepair_offset' => '1' };  #                       'basepair_offset' => '1' };
1194      my $color = "4";      my $color = "4";
1195    
1196      my $line_data = [];      my $line_data = [];
# Line 1408  Line 1220 
1220          }          }
1221      }      }
1222    
1223        my $line_config = { 'title' => $thing->acc,
1224                            'short_title' => $name_value,
1225                            'basepair_offset' => '1' };
1226    
1227      my $name;      my $name;
1228      $name = {"title" => $name_title,      $name = {"title" => $name_title,
1229               "value" => $name_value};               "value" => $name_value};
# Line 1454  Line 1270 
1270    
1271  }  }
1272    
1273    sub display_table {
1274        my ($self,$dataset) = @_;
1275        my $cgi = new CGI;
1276        my $data = [];
1277        my $count = 0;
1278        my $content;
1279    
1280        foreach my $thing (@$dataset) {
1281            next if ($thing->type !~ /dom/);
1282            my $single_domain = [];
1283            $count++;
1284    
1285            my $db_and_id = $thing->acc;
1286            my ($db,$id) = split("::",$db_and_id);
1287    
1288            my $dbmaster = DBMaster->new(-database =>'Ontology');
1289    
1290            my ($name_title,$name_value,$description_title,$description_value);
1291            if($db eq "CDD"){
1292                my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1293                if(!scalar(@$cdd_objs)){
1294                    $name_title = "name";
1295                    $name_value = "not available";
1296                    $description_title = "description";
1297                    $description_value = "not available";
1298                }
1299                else{
1300                    my $cdd_obj = $cdd_objs->[0];
1301                    $name_title = "name";
1302                    $name_value = $cdd_obj->term;
1303                    $description_title = "description";
1304                    $description_value = $cdd_obj->description;
1305                }
1306            }
1307    
1308            my $location =  $thing->start . " - " . $thing->stop;
1309    
1310            push(@$single_domain,$db);
1311            push(@$single_domain,$thing->acc);
1312            push(@$single_domain,$name_value);
1313            push(@$single_domain,$location);
1314            push(@$single_domain,$thing->evalue);
1315            push(@$single_domain,$description_value);
1316            push(@$data,$single_domain);
1317        }
1318    
1319        if ($count >0){
1320            $content = $data;
1321        }
1322        else
1323        {
1324            $content = "<p>This PEG does not have any similarities to domains</p>";
1325        }
1326    }
1327    
1328    
1329  #########################################  #########################################
1330  #########################################  #########################################
1331  package Observation::Location;  package Observation::Location;
# Line 1471  Line 1343 
1343      $self->{cello_score} = $dataset->{'cello_score'};      $self->{cello_score} = $dataset->{'cello_score'};
1344      $self->{tmpred_score} = $dataset->{'tmpred_score'};      $self->{tmpred_score} = $dataset->{'tmpred_score'};
1345      $self->{tmpred_locations} = $dataset->{'tmpred_locations'};      $self->{tmpred_locations} = $dataset->{'tmpred_locations'};
1346        $self->{phobius_signal_location} = $dataset->{'phobius_signal_location'};
1347        $self->{phobius_tm_locations} = $dataset->{'phobius_tm_locations'};
1348    
1349      bless($self,$class);      bless($self,$class);
1350      return $self;      return $self;
1351  }  }
1352    
1353    sub display_cello {
1354        my ($thing) = @_;
1355        my $html;
1356        my $cello_location = $thing->cello_location;
1357        my $cello_score = $thing->cello_score;
1358        if($cello_location){
1359            $html .= "<p>CELLO prediction: $cello_location </p>";
1360            $html .= "<p>CELLO score: $cello_score </p>";
1361        }
1362        return ($html);
1363    }
1364    
1365  sub display {  sub display {
1366      my ($thing,$gd,$fid) = @_;      my ($thing,$gd) = @_;
1367    
1368        my $fid = $thing->fig_id;
1369      my $fig= new FIG;      my $fig= new FIG;
1370      my $length = length($fig->get_translation($fid));      my $length = length($fig->get_translation($fid));
1371    
# Line 1491  Line 1378 
1378      my $tmpred_score = $thing->tmpred_score;      my $tmpred_score = $thing->tmpred_score;
1379      my @tmpred_locations = split(",",$thing->tmpred_locations);      my @tmpred_locations = split(",",$thing->tmpred_locations);
1380    
1381        my $phobius_signal_location = $thing->phobius_signal_location;
1382        my @phobius_tm_locations = split(",",$thing->phobius_tm_locations);
1383    
1384      my $lines = [];      my $lines = [];
     my $line_config = { 'title' => 'Localization Evidence',  
                         'short_title' => 'Local',  
                         'basepair_offset' => '1' };  
1385    
1386      #color is      #color is
1387      my $color = "5";      my $color = "6";
1388    
1389      my $line_data = [];  =pod=
1390    
1391      if($cello_location){      if($cello_location){
1392          my $cello_descriptions = [];          my $cello_descriptions = [];
1393            my $line_data =[];
1394    
1395            my $line_config = { 'title' => 'Localization Evidence',
1396                                'short_title' => 'CELLO',
1397                                'basepair_offset' => '1' };
1398    
1399          my $description_cello_location = {"title" => 'Best Cello Location',          my $description_cello_location = {"title" => 'Best Cello Location',
1400                                            "value" => $cello_location};                                            "value" => $cello_location};
1401    
# Line 1515  Line 1408 
1408    
1409          my $element_hash = {          my $element_hash = {
1410              "title" => "CELLO",              "title" => "CELLO",
1411                "color"=> $color,
1412              "start" => "1",              "start" => "1",
1413              "end" =>  $length + 1,              "end" =>  $length + 1,
1414              "color"=> $color,              "zlayer" => '1',
             "type" => 'box',  
             "zlayer" => '2',  
1415              "description" => $cello_descriptions};              "description" => $cello_descriptions};
1416    
1417          push(@$line_data,$element_hash);          push(@$line_data,$element_hash);
1418            $gd->add_line($line_data, $line_config);
1419      }      }
1420    
1421      my $color = "6";  =cut
1422      #if(0){  
1423        $color = "2";
1424      if($tmpred_score){      if($tmpred_score){
1425            my $line_data =[];
1426            my $line_config = { 'title' => 'Localization Evidence',
1427                                'short_title' => 'Transmembrane',
1428                                'basepair_offset' => '1' };
1429    
1430          foreach my $tmpred (@tmpred_locations){          foreach my $tmpred (@tmpred_locations){
1431              my $descriptions = [];              my $descriptions = [];
1432              my ($begin,$end) =split("-",$tmpred);              my ($begin,$end) =split("-",$tmpred);
# Line 1542  Line 1441 
1441              "end" =>  $end + 1,              "end" =>  $end + 1,
1442              "color"=> $color,              "color"=> $color,
1443              "zlayer" => '5',              "zlayer" => '5',
1444              "type" => 'smallbox',              "type" => 'box',
1445              "description" => $descriptions};              "description" => $descriptions};
1446    
1447              push(@$line_data,$element_hash);              push(@$line_data,$element_hash);
1448    
1449          }          }
1450            $gd->add_line($line_data, $line_config);
1451      }      }
1452    
1453      my $color = "1";      if((scalar(@phobius_tm_locations) > 0) || $phobius_signal_location){
1454            my $line_data =[];
1455            my $line_config = { 'title' => 'Localization Evidence',
1456                                'short_title' => 'Phobius',
1457                                'basepair_offset' => '1' };
1458    
1459            foreach my $tm_loc (@phobius_tm_locations){
1460                my $descriptions = [];
1461                my $description_phobius_tm_locations = {"title" => 'Phobius TM Location',
1462                                 "value" => $tm_loc};
1463                push(@$descriptions,$description_phobius_tm_locations);
1464    
1465                my ($begin,$end) =split("-",$tm_loc);
1466    
1467                my $element_hash = {
1468                "title" => "phobius transmembrane location",
1469                "start" => $begin + 1,
1470                "end" =>  $end + 1,
1471                "color"=> '6',
1472                "zlayer" => '4',
1473                "type" => 'bigbox',
1474                "description" => $descriptions};
1475    
1476                push(@$line_data,$element_hash);
1477    
1478            }
1479    
1480            if($phobius_signal_location){
1481                my $descriptions = [];
1482                my $description_phobius_signal_location = {"title" => 'Phobius Signal Location',
1483                                 "value" => $phobius_signal_location};
1484                push(@$descriptions,$description_phobius_signal_location);
1485    
1486    
1487                my ($begin,$end) =split("-",$phobius_signal_location);
1488                my $element_hash = {
1489                "title" => "phobius signal locations",
1490                "start" => $begin + 1,
1491                "end" =>  $end + 1,
1492                "color"=> '1',
1493                "zlayer" => '5',
1494                "type" => 'box',
1495                "description" => $descriptions};
1496                push(@$line_data,$element_hash);
1497            }
1498    
1499            $gd->add_line($line_data, $line_config);
1500        }
1501    
1502    
1503        $color = "1";
1504      if($signal_peptide_score){      if($signal_peptide_score){
1505            my $line_data = [];
1506          my $descriptions = [];          my $descriptions = [];
1507    
1508            my $line_config = { 'title' => 'Localization Evidence',
1509                                'short_title' => 'SignalP',
1510                                'basepair_offset' => '1' };
1511    
1512          my $description_signal_peptide_score = {"title" => 'signal peptide score',          my $description_signal_peptide_score = {"title" => 'signal peptide score',
1513                                                  "value" => $signal_peptide_score};                                                  "value" => $signal_peptide_score};
1514    
# Line 1565  Line 1522 
1522          my $element_hash = {          my $element_hash = {
1523              "title" => "SignalP",              "title" => "SignalP",
1524              "start" => $cleavage_loc_begin - 2,              "start" => $cleavage_loc_begin - 2,
1525              "end" =>  $cleavage_loc_end + 3,              "end" =>  $cleavage_loc_end + 1,
1526              "type" => 'bigbox',              "type" => 'bigbox',
1527              "color"=> $color,              "color"=> $color,
1528              "zlayer" => '10',              "zlayer" => '10',
1529              "description" => $descriptions};              "description" => $descriptions};
1530    
1531          push(@$line_data,$element_hash);          push(@$line_data,$element_hash);
     }  
   
1532      $gd->add_line($line_data, $line_config);      $gd->add_line($line_data, $line_config);
1533        }
1534    
1535      return ($gd);      return ($gd);
1536    
# Line 1622  Line 1578 
1578    return $self->{cello_score};    return $self->{cello_score};
1579  }  }
1580    
1581    sub phobius_signal_location {
1582      my ($self) = @_;
1583      return $self->{phobius_signal_location};
1584    }
1585    
1586    sub phobius_tm_locations {
1587      my ($self) = @_;
1588      return $self->{phobius_tm_locations};
1589    }
1590    
1591    
1592    
1593  #########################################  #########################################
1594  #########################################  #########################################
# Line 1652  Line 1619 
1619    
1620  =head3 display()  =head3 display()
1621    
1622    If available use the function specified here to display a graphical observation.
1623    This code will display a graphical view of the similarities using the genome drawer object
1624    
1625    =cut
1626    
1627    sub display {
1628        my ($self,$gd) = @_;
1629    
1630        my $fig = new FIG;
1631        my $peg = $self->acc;
1632    
1633        my $organism = $self->organism;
1634        my $genome = $fig->genome_of($peg);
1635        my ($org_tax) = ($genome) =~ /(.*)\./;
1636        my $function = $self->function;
1637        my $abbrev_name = $fig->abbrev($organism);
1638        my $align_start = $self->qstart;
1639        my $align_stop = $self->qstop;
1640        my $hit_start = $self->hstart;
1641        my $hit_stop = $self->hstop;
1642    
1643        my $tax_link = "http://www.ncbi.nlm.nih.gov/Taxonomy/Browser/wwwtax.cgi?id=" . $org_tax;
1644    
1645        my $line_config = { 'title' => "$organism [$org_tax]",
1646                            'short_title' => "$abbrev_name",
1647                            'title_link' => '$tax_link',
1648                            'basepair_offset' => '0'
1649                            };
1650    
1651        my $line_data = [];
1652    
1653        my $element_hash;
1654        my $links_list = [];
1655        my $descriptions = [];
1656    
1657        # get subsystem information
1658        my $url_link = "http://seed-viewer.theseed.org/index.cgi?action=ShowAnnotation&prot=".$peg;
1659    
1660        my $link;
1661        $link = {"link_title" => $peg,
1662                 "link" => $url_link};
1663        push(@$links_list,$link);
1664    
1665        my @subsystems = $fig->peg_to_subsystems($peg);
1666        foreach my $subsystem (@subsystems){
1667            my $link;
1668            $link = {"link" => "http://seed-viewer.theseed.org/index.cgi?action=ShowSubsystem&subsystem_name=$subsystem",
1669                     "link_title" => $subsystem};
1670            push(@$links_list,$link);
1671        }
1672    
1673        my $description_function;
1674        $description_function = {"title" => "function",
1675                                 "value" => $function};
1676        push(@$descriptions,$description_function);
1677    
1678        my ($description_ss, $ss_string);
1679        $ss_string = join (",", @subsystems);
1680        $description_ss = {"title" => "subsystems",
1681                           "value" => $ss_string};
1682        push(@$descriptions,$description_ss);
1683    
1684        my $description_loc;
1685        $description_loc = {"title" => "location start",
1686                            "value" => $hit_start};
1687        push(@$descriptions, $description_loc);
1688    
1689        $description_loc = {"title" => "location stop",
1690                            "value" => $hit_stop};
1691        push(@$descriptions, $description_loc);
1692    
1693        my $evalue = $self->evalue;
1694        while ($evalue =~ /-0/)
1695        {
1696            my ($chunk1, $chunk2) = split(/-/, $evalue);
1697            $chunk2 = substr($chunk2,1);
1698            $evalue = $chunk1 . "-" . $chunk2;
1699        }
1700    
1701        my $color = &color($evalue);
1702    
1703        my $description_eval = {"title" => "E-Value",
1704                                "value" => $evalue};
1705        push(@$descriptions, $description_eval);
1706    
1707        my $identity = $self->identity;
1708        my $description_identity = {"title" => "Identity",
1709                                    "value" => $identity};
1710        push(@$descriptions, $description_identity);
1711    
1712        $element_hash = {
1713            "title" => $peg,
1714            "start" => $align_start,
1715            "end" =>  $align_stop,
1716            "type"=> 'box',
1717            "color"=> $color,
1718            "zlayer" => "2",
1719            "links_list" => $links_list,
1720            "description" => $descriptions
1721            };
1722        push(@$line_data,$element_hash);
1723        $gd->add_line($line_data, $line_config);
1724    
1725        return ($gd);
1726    
1727    }
1728    
1729    =head3 display_domain_composition()
1730    
1731    If available use the function specified here to display a graphical observation of the CDD(later Pfam or selected) domains that occur in the set of similar proteins
1732    
1733    =cut
1734    
1735    sub display_domain_composition {
1736        my ($self,$gd) = @_;
1737    
1738        my $fig = new FIG;
1739        my $peg = $self->acc;
1740    
1741        my $line_data = [];
1742        my $links_list = [];
1743        my $descriptions = [];
1744    
1745        my @domain_query_results =$fig->get_attributes($peg,"CDD");
1746    
1747        foreach $dqr (@domain_query_results){
1748            my $key = @$dqr[1];
1749            my @parts = split("::",$key);
1750            my $db = $parts[0];
1751            my $id = $parts[1];
1752            my $val = @$dqr[2];
1753            my $from;
1754            my $to;
1755            my $evalue;
1756    
1757            if($val =~/^(\d+\.\d+|0\.0);(\d+)-(\d+)/){
1758                my $raw_evalue = $1;
1759                $from = $2;
1760                $to = $3;
1761                if($raw_evalue =~/(\d+)\.(\d+)/){
1762                    my $part2 = 1000 - $1;
1763                    my $part1 = $2/100;
1764                    $evalue = $part1."e-".$part2;
1765                }
1766                else{
1767                    $evalue = "0.0";
1768                }
1769            }
1770    
1771            my $dbmaster = DBMaster->new(-database =>'Ontology');
1772            my ($name_value,$description_value);
1773    
1774            if($db eq "CDD"){
1775                my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1776                if(!scalar(@$cdd_objs)){
1777                    $name_title = "name";
1778                    $name_value = "not available";
1779                    $description_title = "description";
1780                    $description_value = "not available";
1781                }
1782                else{
1783                    my $cdd_obj = $cdd_objs->[0];
1784                    $name_value = $cdd_obj->term;
1785                    $description_value = $cdd_obj->description;
1786                }
1787            }
1788    
1789            my $domain_name;
1790            $domain_name = {"title" => "name",
1791                     "value" => $name_value};
1792            push(@$descriptions,$domain_name);
1793    
1794            my $description;
1795            $description = {"title" => "description",
1796                            "value" => $description_value};
1797            push(@$descriptions,$description);
1798    
1799            my $score;
1800            $score = {"title" => "score",
1801                      "value" => $evalue};
1802            push(@$descriptions,$score);
1803    
1804            my $link_id = $id;
1805            my $link;
1806            my $link_url;
1807            if ($db eq "CDD"){$link_url = "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"}
1808            elsif($db eq "PFAM"){$link_url = "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?$link_id"}
1809            else{$link_url = "NO_URL"}
1810    
1811            $link = {"link_title" => $name_value,
1812                     "link" => $link_url};
1813            push(@$links_list,$link);
1814    
1815            my $domain_element_hash = {
1816                "title" => $peg,
1817                "start" => $from,
1818                "end" =>  $to,
1819                "type"=> 'box',
1820                "zlayer" => '4',
1821                "links_list" => $links_list,
1822                "description" => $descriptions
1823                };
1824    
1825            push(@$line_data,$domain_element_hash);
1826    
1827            #just one CDD domain for now, later will add option for multiple domains from selected DB
1828            last;
1829        }
1830    
1831        my $line_config = { 'title' => $peg,
1832                            'short_title' => $peg,
1833                            'basepair_offset' => '1' };
1834    
1835        $gd->add_line($line_data, $line_config);
1836    
1837        return ($gd);
1838    
1839    }
1840    
1841    =head3 display_table()
1842    
1843  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
1844  This code will display a table for the similarities protein  This code will display a table for the similarities protein
1845    
# Line 1659  Line 1847 
1847    
1848  =cut  =cut
1849    
1850  sub display {  sub display_table {
1851      my ($self,$cgi,$dataset) = @_;      my ($self,$dataset, $scroll_list, $query_fid) = @_;
1852    
1853      my $data = [];      my $data = [];
1854      my $count = 0;      my $count = 0;
1855      my $content;      my $content;
1856      my $fig = new FIG;      my $fig = new FIG;
1857        my $cgi = new CGI;
1858        my @ids;
1859        foreach my $thing (@$dataset) {
1860            next if ($thing->class ne "SIM");
1861            push (@ids, $thing->acc);
1862        }
1863    
1864        my (%box_column, %subsystems_column, %evidence_column, %e_identical);
1865    
1866        # get the column for the subsystems
1867        %subsystems_column = &get_subsystems_column(\@ids);
1868    
1869        # get the column for the evidence codes
1870        %evidence_column = &get_evidence_column(\@ids);
1871    
1872        # get the column for pfam_domain
1873        %pfam_column = &get_pfam_column(\@ids);
1874    
1875        my %e_identical = &get_essentially_identical($query_fid);
1876        my $all_aliases = $fig->feature_aliases_bulk(\@ids);
1877    
1878      foreach my $thing (@$dataset) {      foreach my $thing (@$dataset) {
         my $single_domain = [];  
1879          next if ($thing->class ne "SIM");          next if ($thing->class ne "SIM");
1880            my $single_domain = [];
1881          $count++;          $count++;
1882    
1883          my $id = $thing->acc;          my $id = $thing->acc;
1884    
1885          # add the subsystem information          my $iden    = $thing->identity;
1886          my @in_sub  = $fig->peg_to_subsystems($id);          my $ln1     = $thing->qlength;
1887          my $in_sub;          my $ln2     = $thing->hlength;
1888            my $b1      = $thing->qstart;
1889            my $e1      = $thing->qstop;
1890            my $b2      = $thing->hstart;
1891            my $e2      = $thing->hstop;
1892            my $d1      = abs($e1 - $b1) + 1;
1893            my $d2      = abs($e2 - $b2) + 1;
1894            my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";
1895            my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";
1896    
1897          if (@in_sub > 0) {          # checkbox column
1898              $in_sub = @in_sub;          my $field_name = "tables_" . $id;
1899            my $pair_name = "visual_" . $id;
1900            my $box_col = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
1901    
1902            # get the linked fig id
1903            my $fig_col;
1904            if (defined ($e_identical{$id})){
1905                $fig_col = &HTML::set_prot_links($cgi,$id) . "*";
1906            }
1907            else{
1908                $fig_col = &HTML::set_prot_links($cgi,$id);
1909            }
1910    
1911              # RAE: add a javascript popup with all the subsystems          push(@$single_domain,$box_col);                        # permanent column
1912              my $ss_list=join "<br>", map { my $g = $_; $g =~ s/\_/ /g; $_ = $g } sort {$a cmp $b} @in_sub;          push(@$single_domain,$fig_col);                        # permanent column
1913              $in_sub = $cgi->a( {id=>"subsystems", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Subsystems', '$ss_list', ''); this.tooltip.addHandler(); return false;"}, $in_sub);          push(@$single_domain,$thing->evalue);                  # permanent column
1914            push(@$single_domain,"$iden\%");                       # permanent column
1915            push(@$single_domain,$reg1);                           # permanent column
1916            push(@$single_domain,$reg2);                           # permanent column
1917            push(@$single_domain,$thing->organism);                # permanent column
1918            push(@$single_domain,$thing->function);                # permanent column
1919            foreach my $col (sort keys %$scroll_list){
1920                if ($col =~ /associated_subsystem/)          {push(@$single_domain,$subsystems_column{$id});}
1921                elsif ($col =~ /evidence/)                   {push(@$single_domain,$evidence_column{$id});}
1922                elsif ($col =~ /pfam_domains/)               {push(@$single_domain,$pfam_column{$id});}
1923                elsif ($col =~ /ncbi_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'NCBI', $all_aliases));}
1924                elsif ($col =~ /refseq_id/)                  {push(@$single_domain,&get_prefer($thing->acc, 'RefSeq', $all_aliases));}
1925                elsif ($col =~ /swissprot_id/)               {push(@$single_domain,&get_prefer($thing->acc, 'SwissProt', $all_aliases));}
1926                elsif ($col =~ /uniprot_id/)                 {push(@$single_domain,&get_prefer($thing->acc, 'UniProt', $all_aliases));}
1927                elsif ($col =~ /tigr_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'TIGR', $all_aliases));}
1928                elsif ($col =~ /pir_id/)                     {push(@$single_domain,&get_prefer($thing->acc, 'PIR', $all_aliases));}
1929                elsif ($col =~ /kegg_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'KEGG', $all_aliases));}
1930                elsif ($col =~ /trembl_id/)                  {push(@$single_domain,&get_prefer($thing->acc, 'TrEMBL', $all_aliases));}
1931                elsif ($col =~ /asap_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'ASAP', $all_aliases));}
1932                elsif ($col =~ /jgi_id/)                     {push(@$single_domain,&get_prefer($thing->acc, 'JGI', $all_aliases));}
1933            }
1934            push(@$data,$single_domain);
1935        }
1936    
1937        if ($count >0 ){
1938            $content = $data;
1939        }
1940        else{
1941            $content = "<p>This PEG does not have any similarities</p>";
1942        }
1943        return ($content);
1944    }
1945    
1946    sub get_box_column{
1947        my ($ids) = @_;
1948        my %column;
1949        foreach my $id (@$ids){
1950            my $field_name = "tables_" . $id;
1951            my $pair_name = "visual_" . $id;
1952            $column{$id} = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
1953        }
1954        return (%column);
1955    }
1956    
1957    sub get_subsystems_column{
1958        my ($ids) = @_;
1959    
1960        my $fig = new FIG;
1961        my $cgi = new CGI;
1962        my %in_subs  = $fig->subsystems_for_pegs($ids);
1963        my %column;
1964        foreach my $id (@$ids){
1965            my @in_sub = @{$in_subs{$id}} if (defined $in_subs{$id});
1966            my @subsystems;
1967    
1968            if (@in_sub > 0) {
1969                my $count = 1;
1970                foreach my $array(@in_sub){
1971                    push (@subsystems, $count . ". " . $$array[0]);
1972                    $count++;
1973                }
1974                my $in_sub_line = join ("<br>", @subsystems);
1975                $column{$id} = $in_sub_line;
1976          } else {          } else {
1977              $in_sub = "&nbsp;";              $column{$id} = "&nbsp;";
1978            }
1979          }          }
1980        return (%column);
1981    }
1982    
1983    sub get_essentially_identical{
1984        my ($fid) = @_;
1985        my $fig = new FIG;
1986    
1987        my %id_list;
1988        my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);
1989    
1990        foreach my $id (@maps_to) {
1991            if (($id ne $fid) && ($fig->function_of($id))) {
1992                $id_list{$id} = 1;
1993            }
1994        }
1995        return(%id_list);
1996    }
1997    
1998    
1999    sub get_evidence_column{
2000        my ($ids) = @_;
2001        my $fig = new FIG;
2002        my $cgi = new CGI;
2003        my (%column, %code_attributes);
2004    
2005        my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($ids);
2006        foreach my $key (@codes){
2007            push (@{$code_attributes{$$key[0]}}, $key);
2008        }
2009    
2010        foreach my $id (@$ids){
2011          # add evidence code with tool tip          # add evidence code with tool tip
2012          my $ev_codes=" &nbsp; ";          my $ev_codes=" &nbsp; ";
2013          my @ev_codes = "";          my @ev_codes = "";
2014    
2015          if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {          if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {
2016              my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($id);              my @codes;
2017                @codes = @{$code_attributes{$id}} if (defined @{$code_attributes{$id}});
2018              @ev_codes = ();              @ev_codes = ();
2019              foreach my $code (@codes) {              foreach my $code (@codes) {
2020                  my $pretty_code = $code->[2];                  my $pretty_code = $code->[2];
# Line 1711  Line 2033 
2033                                  {                                  {
2034                                      id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes));                                      id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes));
2035          }          }
2036            $column{$id}=$ev_codes;
2037        }
2038        return (%column);
2039    }
2040    
2041          # add the aliases  sub get_pfam_column{
2042          my $aliases = undef;      my ($ids) = @_;
2043          $aliases = &html_enc( join( ", ", $fig->feature_aliases($id) ) );      my $fig = new FIG;
2044          $aliases = &HTML::set_prot_links( $cgi, $aliases );      my $cgi = new CGI;
2045          $aliases ||= "&nbsp;";      my (%column, %code_attributes);
2046        my $dbmaster = DBMaster->new(-database =>'Ontology');
2047    
2048          my $iden    = $thing->identity;      my @codes = grep { $_->[1] =~ /^PFAM/i } $fig->get_attributes($ids);
2049          my $ln1     = $thing->qlength;      foreach my $key (@codes){
2050          my $ln2     = $thing->hlength;          push (@{$code_attributes{$$key[0]}}, $$key[1]);
2051          my $b1      = $thing->qstart;      }
         my $e1      = $thing->qstop;  
         my $b2      = $thing->hstart;  
         my $e2      = $thing->hstop;  
         my $d1      = abs($e1 - $b1) + 1;  
         my $d2      = abs($e2 - $b2) + 1;  
         my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";  
         my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";  
2052    
2053        foreach my $id (@$ids){
2054            # add evidence code with tool tip
2055            my $pfam_codes=" &nbsp; ";
2056            my @pfam_codes = "";
2057            my %description_codes;
2058    
2059          push(@$single_domain,$thing->database);          if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {
2060          push(@$single_domain,&HTML::set_prot_links($cgi,$thing->acc));              my @codes;
2061          push(@$single_domain,$thing->evalue);              @codes = @{$code_attributes{$id}} if (defined @{$code_attributes{$id}});
2062          push(@$single_domain,"$iden\%");              @pfam_codes = ();
2063          push(@$single_domain,$reg1);              foreach my $code (@codes) {
2064          push(@$single_domain,$reg2);                  my @parts = split("::",$code);
2065          push(@$single_domain,$in_sub);                  my $pfam_link = "<a href=http://www.sanger.ac.uk//cgi-bin/Pfam/getacc?" . $parts[1] . ">$parts[1]</a>";
2066          push(@$single_domain,$ev_codes);                  if (defined ($description_codes{$parts[1]})){
2067          push(@$single_domain,$thing->organism);                      push(@pfam_codes, "$description_codes{$parts[1]} ($parts[1])");
2068          push(@$single_domain,$thing->function);                  }
2069          push(@$single_domain,$aliases);                  else {
2070          push(@$data,$single_domain);                      my $description = $dbmaster->pfam->get_objects( { 'id' => $parts[1] } );
2071                        $description_codes{$parts[1]} = ${$$description[0]}{term};
2072                        push(@pfam_codes, "${$$description[0]}{term} ($pfam_link)");
2073                    }
2074                }
2075      }      }
2076    
2077      if ($count >0){          $column{$id}=join("<br><br>", @pfam_codes);
         $content = $data;  
2078      }      }
2079      else      return (%column);
2080      {  
2081          $content = "<p>This PEG does not have any similarities</p>";  }
2082    
2083    sub get_prefer {
2084        my ($fid, $db, $all_aliases) = @_;
2085        my $fig = new FIG;
2086        my $cgi = new CGI;
2087    
2088        foreach my $alias (@{$$all_aliases{$fid}}){
2089            my $id_db = &Observation::get_database($alias);
2090            if ($id_db eq $db){
2091                my $acc_col .= &HTML::set_prot_links($cgi,$alias);
2092                return ($acc_col);
2093      }      }
2094      return ($content);      }
2095        return (" ");
2096  }  }
2097    
2098  sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }  sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
2099    
2100    sub color {
2101        my ($evalue) = @_;
2102    
2103        my $color;
2104        if ($evalue <= 1e-170){
2105            $color = 51;
2106        }
2107        elsif (($evalue <= 1e-120) && ($evalue > 1e-170)){
2108            $color = 52;
2109        }
2110        elsif (($evalue <= 1e-90) && ($evalue > 1e-120)){
2111            $color = 53;
2112        }
2113        elsif (($evalue <= 1e-70) && ($evalue > 1e-90)){
2114            $color = 54;
2115        }
2116        elsif (($evalue <= 1e-40) && ($evalue > 1e-70)){
2117            $color = 55;
2118        }
2119        elsif (($evalue <= 1e-20) && ($evalue > 1e-40)){
2120            $color = 56;
2121        }
2122        elsif (($evalue <= 1e-5) && ($evalue > 1e-20)){
2123            $color = 57;
2124        }
2125        elsif (($evalue <= 1) && ($evalue > 1e-5)){
2126            $color = 58;
2127        }
2128        elsif (($evalue <= 10) && ($evalue > 1)){
2129            $color = 59;
2130        }
2131        else{
2132            $color = 60;
2133        }
2134    
2135    
2136        return ($color);
2137    }
2138    
2139    
2140  ############################  ############################
# Line 1768  Line 2146 
2146    
2147      my ($class,$dataset) = @_;      my ($class,$dataset) = @_;
2148      my $self = $class->SUPER::new($dataset);      my $self = $class->SUPER::new($dataset);
2149        $self->{context} = $dataset->{'context'};
2150      bless($self,$class);      bless($self,$class);
2151      return $self;      return $self;
2152  }  }
2153    
2154  sub display {  sub display {
2155      my ($self,$gd, $fid) = @_;      my ($self,$gd,$selected_taxonomies) = @_;
2156    
2157        my $fid = $self->fig_id;
2158        my $compare_or_coupling = $self->context;
2159        my $gd_window_size = $gd->window_size;
2160      my $fig = new FIG;      my $fig = new FIG;
2161      my $all_regions = [];      my $all_regions = [];
2162        my $gene_associations={};
2163    
2164      #get the organism genome      #get the organism genome
2165      my $target_genome = $fig->genome_of($fid);      my $target_genome = $fig->genome_of($fid);
2166        $gene_associations->{$fid}->{"organism"} = $target_genome;
2167        $gene_associations->{$fid}->{"main_gene"} = $fid;
2168        $gene_associations->{$fid}->{"reverse_flag"} = 0;
2169    
2170      # get location of the gene      # get location of the gene
2171      my $data = $fig->feature_location($fid);      my $data = $fig->feature_location($fid);
2172      my ($contig, $beg, $end);      my ($contig, $beg, $end);
2173        my %reverse_flag;
2174    
2175      if ($data =~ /(.*)_(\d+)_(\d+)$/){      if ($data =~ /(.*)_(\d+)_(\d+)$/){
2176          $contig = $1;          $contig = $1;
# Line 1792  Line 2178 
2178          $end = $3;          $end = $3;
2179      }      }
2180    
2181        my $offset;
2182      my ($region_start, $region_end);      my ($region_start, $region_end);
2183      if ($beg < $end)      if ($beg < $end)
2184      {      {
2185          $region_start = $beg - 4000;          $region_start = $beg - 4000;
2186          $region_end = $end+4000;          $region_end = $end+4000;
2187            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
2188      }      }
2189      else      else
2190      {      {
2191          $region_end = $end+4000;          $region_start = $end-4000;
2192          $region_start = $beg-4000;          $region_end = $beg+4000;
2193            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
2194            $reverse_flag{$target_genome} = $fid;
2195            $gene_associations->{$fid}->{"reverse_flag"} = 1;
2196      }      }
2197    
2198      # call genes in region      # call genes in region
2199      my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_end);      my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_end);
2200      push(@$all_regions,$target_gene_features);      push(@$all_regions,$target_gene_features);
2201      my (@start_array_region);      my (@start_array_region);
2202      push (@start_array_region, $region_start);      push (@start_array_region, $offset);
2203    
2204      my %all_genes;      my %all_genes;
2205      my %all_genomes;      my %all_genomes;
2206      foreach my $feature (@$target_gene_features){ $all_genes{$feature} = 1;}      foreach my $feature (@$target_gene_features){ $all_genes{$feature} = $fid; $gene_associations->{$feature}->{"main_gene"}=$fid;}
2207    
2208        if ($compare_or_coupling eq "diverse")
2209        {
2210      my @coup = grep { $_->[1]} $fig->coupling_and_evidence($fid,5000,1e-10,4,1);      my @coup = grep { $_->[1]} $fig->coupling_and_evidence($fid,5000,1e-10,4,1);
2211    
2212      my $coup_count = 0;      my $coup_count = 0;
2213    
2214      foreach my $pair (@{$coup[0]->[2]}) {      foreach my $pair (@{$coup[0]->[2]}) {
2215          last if ($coup_count > 10);              #   last if ($coup_count > 10);
2216          my ($peg1,$peg2) = @$pair;          my ($peg1,$peg2) = @$pair;
2217    
         my $location = $fig->feature_location($peg1);  
2218          my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome);          my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome);
2219                $pair_genome = $fig->genome_of($peg1);
2220    
2221                my $location = $fig->feature_location($peg1);
2222          if($location =~/(.*)_(\d+)_(\d+)$/){          if($location =~/(.*)_(\d+)_(\d+)$/){
2223              $pair_contig = $1;              $pair_contig = $1;
2224              $pair_beg = $2;              $pair_beg = $2;
# Line 1832  Line 2227 
2227              {              {
2228                  $pair_region_start = $pair_beg - 4000;                  $pair_region_start = $pair_beg - 4000;
2229                  $pair_region_stop = $pair_end+4000;                  $pair_region_stop = $pair_end+4000;
2230                        $offset = ($pair_beg+(($pair_end-$pair_beg)/2))-($gd_window_size/2);
2231              }              }
2232              else              else
2233              {              {
2234                  $pair_region_stop = $pair_end+4000;                      $pair_region_start = $pair_end-4000;
2235                  $pair_region_start = $pair_beg-4000;                      $pair_region_stop = $pair_beg+4000;
2236                        $offset = ($pair_end+(($pair_beg-$pair_end)/2))-($gd_window_size/2);
2237                        $reverse_flag{$pair_genome} = $peg1;
2238              }              }
2239    
2240              push (@start_array_region, $pair_region_start);                  push (@start_array_region, $offset);
2241    
             $pair_genome = $fig->genome_of($peg1);  
2242              $all_genomes{$pair_genome} = 1;              $all_genomes{$pair_genome} = 1;
2243              my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop);              my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop);
2244              push(@$all_regions,$pair_features);              push(@$all_regions,$pair_features);
2245              foreach my $pair_feature (@$pair_features){ $all_genes{$pair_feature} = 1;}                  foreach my $pair_feature (@$pair_features){ $all_genes{$pair_feature} = $peg1;}
2246          }          }
2247          $coup_count++;          $coup_count++;
2248      }      }
2249        }
2250        elsif ($compare_or_coupling eq "sims"){
2251            # get the selected boxes
2252            #my @selected_taxonomy = ("Streptococcaceae", "Enterobacteriales");
2253            my @selected_taxonomy = @$selected_taxonomies;
2254    
2255            # get the similarities and store only the ones that match the lineages selected
2256            my @selected_sims;
2257            my @sims= $fig->nsims($fid,20000,10,"fig");
2258    
2259      my $bbh_sets = [];          if (@selected_taxonomy > 0){
2260      my %already;              foreach my $sim (@sims){
2261      foreach my $gene_key (keys(%all_genes)){                  next if ($sim->[1] !~ /fig\|/);
2262          if($already{$gene_key}){next;}                  my $genome = $fig->genome_of($sim->[1]);
2263          my $gene_set = [$gene_key];                  my $lineage = $fig->taxonomy_of($fig->genome_of($sim->[1]));
2264                    foreach my $taxon(@selected_taxonomy){
2265          my $gene_key_genome = $fig->genome_of($gene_key);                      if ($lineage =~ /$taxon/){
2266                            push (@selected_sims, $sim->[1]);
2267          foreach my $genome_key (keys(%all_genomes)){                      }
             #next if ($gene_key_genome eq $genome_key);  
             my $return = $fig->bbh_list($genome_key,[$gene_key]);  
   
             my $feature_list = $return->{$gene_key};  
             foreach my $fl (@$feature_list){  
                 push(@$gene_set,$fl);  
2268              }              }
2269                    my %saw;
2270                    @selected_sims = grep(!$saw{$_}++, @selected_sims);
2271          }          }
         $already{$gene_key} = 1;  
         push(@$bbh_sets,$gene_set);  
2272      }      }
2273    
2274      my %bbh_set_rank;          # get the gene context for the sorted matches
2275      my $order = 0;          foreach my $sim_fid(@selected_sims){
2276      foreach my $set (@$bbh_sets){              #get the organism genome
2277          my $count = scalar(@$set);              my $sim_genome = $fig->genome_of($sim_fid);
2278          $bbh_set_rank{$order} = $count;              $gene_associations->{$sim_fid}->{"organism"} = $sim_genome;
2279          $order++;              $gene_associations->{$sim_fid}->{"main_gene"} = $sim_fid;
2280                $gene_associations->{$sim_fid}->{"reverse_flag"} = 0;
2281    
2282                # get location of the gene
2283                my $data = $fig->feature_location($sim_fid);
2284                my ($contig, $beg, $end);
2285    
2286                if ($data =~ /(.*)_(\d+)_(\d+)$/){
2287                    $contig = $1;
2288                    $beg = $2;
2289                    $end = $3;
2290      }      }
2291    
2292      my %peg_rank;              my $offset;
2293      my $counter =  1;              my ($region_start, $region_end);
2294      foreach my $bbh_order (sort {$bbh_set_rank{$b} <=> $bbh_set_rank{$a}} keys %bbh_set_rank){              if ($beg < $end)
         my $good_set = @$bbh_sets[$bbh_order];  
         my $flag_set = 0;  
         if (scalar (@$good_set) > 1)  
2295          {          {
2296              foreach my $peg (@$good_set){                  $region_start = $beg - 4000;
2297                  if ((!$peg_rank{$peg})){                  $region_end = $end+4000;
2298                      $peg_rank{$peg} = $counter;                  $offset = ($beg+(($end-$beg)/2))-($gd_window_size/2);
                     $flag_set = 1;  
                 }  
             }  
             $counter++ if ($flag_set == 1);  
2299          }          }
2300          else          else
2301          {          {
2302              foreach my $peg (@$good_set){                  $region_start = $end-4000;
2303                  $peg_rank{$peg} = 100;                  $region_end = $beg+4000;
2304                    $offset = ($end+(($beg-$end)/2))-($gd_window_size/2);
2305                    $reverse_flag{$sim_genome} = $sim_fid;
2306                    $gene_associations->{$sim_fid}->{"reverse_flag"} = 1;
2307              }              }
2308    
2309                # call genes in region
2310                my ($sim_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($sim_genome, $contig, $region_start, $region_end);
2311                push(@$all_regions,$sim_gene_features);
2312                push (@start_array_region, $offset);
2313                foreach my $feature (@$sim_gene_features){ $all_genes{$feature} = $sim_fid;$gene_associations->{$feature}->{"main_gene"}=$sim_fid;}
2314                $all_genomes{$sim_genome} = 1;
2315          }          }
2316    
2317      }      }
2318    
2319      open (FH, ">$FIG_Config::temp/good_sets.txt");      # cluster the genes
2320      foreach my $pr (sort {$peg_rank{$a} <=> $peg_rank{$b}} keys(%peg_rank)){ print FH "rank:$peg_rank{$pr}\tpr:$pr\n";}      my @all_pegs = keys %all_genes;
2321      close (FH);      my $color_sets = &cluster_genes($fig,\@all_pegs,$fid);
2322    
2323      foreach my $region (@$all_regions){      foreach my $region (@$all_regions){
2324          my $sample_peg = @$region[0];          my $sample_peg = @$region[0];
# Line 1916  Line 2330 
2330                              'basepair_offset' => '0'                              'basepair_offset' => '0'
2331                              };                              };
2332    
2333          my $offset = shift @start_array_region;          my $offsetting = shift @start_array_region;
2334    
2335            my $second_line_config = { 'title' => "$region_gs",
2336                                       'short_title' => "",
2337                                       'basepair_offset' => '0',
2338                                       'no_middle_line' => '1'
2339                                       };
2340    
2341          my $line_data = [];          my $line_data = [];
2342            my $second_line_data = [];
2343    
2344            # initialize variables to check for overlap in genes
2345            my ($prev_start, $prev_stop, $prev_fig, $second_line_flag);
2346            my $major_line_flag = 0;
2347            my $prev_second_flag = 0;
2348    
2349          foreach my $fid1 (@$region){          foreach my $fid1 (@$region){
2350                $second_line_flag = 0;
2351              my $element_hash;              my $element_hash;
2352              my $links_list = [];              my $links_list = [];
2353              my $descriptions = [];              my $descriptions = [];
2354    
2355              my $color = $peg_rank{$fid1};              my $color = $color_sets->{$fid1};
             if ($color == 1) {  
                 print STDERR "PEG: $fid1, RANK: $color";  
             }  
2356    
2357              # get subsystem information              # get subsystem information
2358              my $function = $fig->function_of($fid1);              my $function = $fig->function_of($fid1);
# Line 1961  Line 2386 
2386              my $fid_location = $fig->feature_location($fid1);              my $fid_location = $fig->feature_location($fid1);
2387              if($fid_location =~/(.*)_(\d+)_(\d+)$/){              if($fid_location =~/(.*)_(\d+)_(\d+)$/){
2388                  my($start,$stop);                  my($start,$stop);
2389                  if ($2 < $3){$start = $2; $stop = $3;}                  $start = $2 - $offsetting;
2390                  else{$stop = $2; $start = $3;}                  $stop = $3 - $offsetting;
2391                  $start = $start - $offset;  
2392                  $stop = $stop - $offset;                  if ( (($prev_start) && ($prev_stop) ) &&
2393                         ( ($start < $prev_start) || ($start < $prev_stop) ||
2394                           ($stop < $prev_start) || ($stop < $prev_stop) )){
2395                        if (($second_line_flag == 0) && ($prev_second_flag == 0)) {
2396                            $second_line_flag = 1;
2397                            $major_line_flag = 1;
2398                        }
2399                    }
2400                    $prev_start = $start;
2401                    $prev_stop = $stop;
2402                    $prev_fig = $fid1;
2403    
2404                    if ((defined($reverse_flag{$region_genome})) && ($reverse_flag{$region_genome} eq $all_genes{$fid1})){
2405                        $start = $gd_window_size - $start;
2406                        $stop = $gd_window_size - $stop;
2407                    }
2408    
2409                  $element_hash = {                  $element_hash = {
2410                      "title" => $fid1,                      "title" => $fid1,
2411                      "start" => $start,                      "start" => $start,
# Line 1975  Line 2416 
2416                      "links_list" => $links_list,                      "links_list" => $links_list,
2417                      "description" => $descriptions                      "description" => $descriptions
2418                  };                  };
2419                  push(@$line_data,$element_hash);  
2420                    # if there is an overlap, put into second line
2421                    if ($second_line_flag == 1){ push(@$second_line_data,$element_hash); $prev_second_flag = 1;}
2422                    else{ push(@$line_data,$element_hash); $prev_second_flag = 0;}
2423              }              }
2424          }          }
2425          $gd->add_line($line_data, $line_config);          $gd->add_line($line_data, $line_config);
2426            $gd->add_line($second_line_data, $second_line_config) if ($major_line_flag == 1);
2427      }      }
2428      return $gd;      return $gd;
2429  }  }
2430    
2431    sub cluster_genes {
2432        my($fig,$all_pegs,$peg) = @_;
2433        my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
2434    
2435        my @color_sets = ();
2436    
2437        $conn = &get_connections_by_similarity($fig,$all_pegs);
2438    
2439        for ($i=0; ($i < @$all_pegs); $i++) {
2440            if ($all_pegs->[$i] eq $peg) { $pegI = $i }
2441            if (! $seen{$i}) {
2442                $cluster = [$i];
2443                $seen{$i} = 1;
2444                for ($j=0; ($j < @$cluster); $j++) {
2445                    $x = $conn->{$cluster->[$j]};
2446                    foreach $k (@$x) {
2447                        if (! $seen{$k}) {
2448                            push(@$cluster,$k);
2449                            $seen{$k} = 1;
2450                        }
2451                    }
2452                }
2453    
2454                if ((@$cluster > 1) || ($cluster->[0] eq $pegI)) {
2455                    push(@color_sets,$cluster);
2456                }
2457            }
2458        }
2459        for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
2460        $red_set = $color_sets[$i];
2461        splice(@color_sets,$i,1);
2462        @color_sets = sort { @$b <=> @$a } @color_sets;
2463        unshift(@color_sets,$red_set);
2464    
2465        my $color_sets = {};
2466        for ($i=0; ($i < @color_sets); $i++) {
2467            foreach $x (@{$color_sets[$i]}) {
2468                $color_sets->{$all_pegs->[$x]} = $i;
2469            }
2470        }
2471        return $color_sets;
2472    }
2473    
2474    sub get_connections_by_similarity {
2475        my($fig,$all_pegs) = @_;
2476        my($i,$j,$tmp,$peg,%pos_of);
2477        my($sim,%conn,$x,$y);
2478    
2479        for ($i=0; ($i < @$all_pegs); $i++) {
2480            $tmp = $fig->maps_to_id($all_pegs->[$i]);
2481            push(@{$pos_of{$tmp}},$i);
2482            if ($tmp ne $all_pegs->[$i]) {
2483                push(@{$pos_of{$all_pegs->[$i]}},$i);
2484            }
2485        }
2486    
2487        foreach $y (keys(%pos_of)) {
2488            $x = $pos_of{$y};
2489            for ($i=0; ($i < @$x); $i++) {
2490                for ($j=$i+1; ($j < @$x); $j++) {
2491                    push(@{$conn{$x->[$i]}},$x->[$j]);
2492                    push(@{$conn{$x->[$j]}},$x->[$i]);
2493                }
2494            }
2495        }
2496    
2497        for ($i=0; ($i < @$all_pegs); $i++) {
2498            foreach $sim ($fig->nsims($all_pegs->[$i],500,10,"raw")) {
2499                if (defined($x = $pos_of{$sim->id2})) {
2500                    foreach $y (@$x) {
2501                        push(@{$conn{$i}},$y);
2502                    }
2503                }
2504            }
2505        }
2506        return \%conn;
2507    }
2508    
2509    sub in {
2510        my($x,$xL) = @_;
2511        my($i);
2512    
2513        for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
2514        return ($i < @$xL);
2515    }

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.38

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3