[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.11, Thu Jun 21 21:15:23 2007 UTC revision 1.26, Wed Jul 25 16:52:04 2007 UTC
# Line 1  Line 1 
1  package Observation;  package Observation;
2    
3    use lib '/vol/ontologies';
4    use DBMaster;
5    
6  require Exporter;  require Exporter;
7  @EXPORT_OK = qw(get_objects);  @EXPORT_OK = qw(get_objects);
8    
9    use FIG_Config;
10  use strict;  use strict;
11  use warnings;  #use warnings;
12  use HTML;  use HTML;
13    
14  1;  1;
# Line 22  Line 26 
26    
27  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).
28    
 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  
   
29  =cut  =cut
30    
31  =head1 BACKGROUND  =head1 BACKGROUND
# Line 66  Line 49 
49    
50  The public methods this package provides are listed below:  The public methods this package provides are listed below:
51    
 =head3 acc()  
52    
53  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()
54    
55    Returns close or diverse for purposes of displaying genomic context
56    
57  =cut  =cut
58    
59  sub acc {  sub context {
60    my ($self) = @_;    my ($self) = @_;
61    
62    return $self->{acc};    return $self->{context};
63  }  }
64    
65  =head3 description()  =head3 rows()
66    
67  The description of the hit. Taken from the data or from the our Ontology database for some cases e.g. IPR or PFAM.  each row in a displayed table
   
 B<Please note:>  
 Either remoteid or description is required.  
68    
69  =cut  =cut
70    
71  sub description {  sub rows {
72    my ($self) = @_;    my ($self) = @_;
73    
74    return $self->{description};    return $self->{rows};
75    }
76    
77    =head3 acc()
78    
79    A valid accession or remote ID (in the style of a db_xref) or a valid local ID (FID) in case this is supported.
80    
81    =cut
82    
83    sub acc {
84      my ($self) = @_;
85      return $self->{acc};
86  }  }
87    
88  =head3 class()  =head3 class()
# Line 118  Line 110 
110    
111  =item PFAM (dom)  =item PFAM (dom)
112    
113  =item SIGNALP (dom)  =item SIGNALP_CELLO_TMPRED (loc)
114    
115  =item  CELLO(loc)  =item PDB (seq)
116    
117  =item TMHMM (loc)  =item TMHMM (loc)
118    
# Line 159  Line 151 
151  sub type {  sub type {
152    my ($self) = @_;    my ($self) = @_;
153    
154    return $self->{acc};    return $self->{type};
155  }  }
156    
157  =head3 start()  =head3 start()
# Line 258  Line 250 
250      return $self->{hlength};      return $self->{hlength};
251  }  }
252    
   
   
253  =head3 evalue()  =head3 evalue()
254    
255  E-value or P-Value if present.  E-value or P-Value if present.
# Line 276  Line 266 
266    
267  Score if present.  Score if present.
268    
 B<Please note: >  
 Either score or eval are required.  
   
269  =cut  =cut
270    
271  sub score {  sub score {
# Line 286  Line 273 
273    return $self->{score};    return $self->{score};
274  }  }
275    
276    =head3 display()
277    
278  =head3 display_method()  will be different for each type
   
 If available use the function specified here to display the "raw" observation.  
 In the case of a BLAST alignment of fid1 and fid2 a cgi script  
 will be called to display the results of running the command "bl2seq fid1 fid2".  
   
 B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evidence.  
279    
280  =cut  =cut
281    
# Line 303  Line 285 
285    
286  }  }
287    
288    =head3 display_table()
289    
290  =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.  
291    
292  =cut  =cut
293    
294  sub url {  sub display_table {
   my ($self) = @_;  
295    
296    my $url = get_url($self->type, $self->acc);    die "Abstract Table Method Called\n";
297    
   return $url;  
298  }  }
299    
300  =head3 get_objects()  =head3 get_objects()
301    
302  This is the B<REAL WORKHORSE> method of this Package.  This is the B<REAL WORKHORSE> method of this Package.
303    
 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.  
   
304  =cut  =cut
305    
306  sub get_objects {  sub get_objects {
307      my ($self,$fid,$classes) = @_;      my ($self,$fid,$scope) = @_;
   
308    
309      my $objects = [];      my $objects = [];
310      my @matched_datasets=();      my @matched_datasets=();
# Line 404  Line 312 
312      # call function that fetches attribute based observations      # call function that fetches attribute based observations
313      # returns an array of arrays of hashes      # returns an array of arrays of hashes
314    
315      if(scalar(@$classes) < 1){      if($scope){
316          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);  
317      }      }
318      else{      else{
         #IPR,CDD,CELLO,PFAM,SIGNALP - attribute based  
319          my %domain_classes;          my %domain_classes;
320          my $identical_flag=0;          $domain_classes{'CDD'} = 1;
         my $pch_flag=0;  
         my $sims_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 eq "SIM")  
             {  
                 $sims_flag = 1;  
             }  
         }  
   
         if ($identical_flag ==1)  
         {  
321              get_identical_proteins($fid,\@matched_datasets);              get_identical_proteins($fid,\@matched_datasets);
         }  
         if ( (defined($domain_classes{IPR})) || (defined($domain_classes{CDD})) || (defined($domain_classes{PFAM})) ) {  
322              get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets);              get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets);
         }  
         if ($pch_flag == 1)  
         {  
             get_functional_coupling($fid,\@matched_datasets);  
         }  
         if ($sims_flag == 1)  
         {  
323              get_sims_observations($fid,\@matched_datasets);              get_sims_observations($fid,\@matched_datasets);
324          }          get_functional_coupling($fid,\@matched_datasets);
325            get_attribute_based_location_observations($fid,\@matched_datasets);
326          #add CELLO and SignalP later          get_pdb_observations($fid,\@matched_datasets);
327      }      }
328    
329      foreach my $dataset (@matched_datasets) {      foreach my $dataset (@matched_datasets) {
# Line 464  Line 337 
337          if ($dataset->{'class'} eq "IDENTICAL"){          if ($dataset->{'class'} eq "IDENTICAL"){
338              $object = Observation::Identical->new($dataset);              $object = Observation::Identical->new($dataset);
339          }          }
340            if ($dataset->{'class'} eq "SIGNALP_CELLO_TMPRED"){
341                $object = Observation::Location->new($dataset);
342            }
343          if ($dataset->{'class'} eq "SIM"){          if ($dataset->{'class'} eq "SIM"){
344              $object = Observation::Sims->new($dataset);              $object = Observation::Sims->new($dataset);
345          }          }
346            if ($dataset->{'class'} eq "CLUSTER"){
347                $object = Observation::Cluster->new($dataset);
348            }
349            if ($dataset->{'class'} eq "PDB"){
350                $object = Observation::PDB->new($dataset);
351            }
352    
353          push (@$objects, $object);          push (@$objects, $object);
354      }      }
355    
# Line 482  Line 365 
365    
366  =cut  =cut
367    
   
 =head3 get_url (internal)  
   
 get_url() return a valid URL or undef for any observation.  
   
 URLs are constructed by looking at the Accession acc()  and  name()  
   
 Info from both attributes is combined with a table of base URLs stored in this function.  
   
 =cut  
   
 sub get_url {  
   
  my ($self) = @_;  
  my $url='';  
   
 # a hash with a URL for each observation; identified by name()  
 #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="  
 #};  
   
 # if (defined $URL{$self->name}) {  
 #     $url = $URL{$self->name}.$self->acc;  
 #     return $url;  
 # }  
 # else  
      return undef;  
 }  
   
 =head3 get_display_method (internal)  
   
 get_display_method() return a valid URL or undef for any observation.  
   
 URLs are constructed by looking at the Accession acc()  and  name()  
 and Info from both attributes is combined with a table of base URLs stored in this function.  
   
 =cut  
   
 sub get_display_method {  
   
  my ($self) = @_;  
   
 # a hash with a URL for each observation; identified by name()  
 #my $URL             => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\  
 #                        'bbh'=> "http://www.theseed.org/featalign.cgi?id1="  
 # };  
   
 #if (defined $URL{$self->name}) {  
 #     $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc;  
 #     return $url;  
 # }  
 # else  
      return undef;  
 }  
   
   
368  sub get_attribute_based_domain_observations{  sub get_attribute_based_domain_observations{
369    
370      # 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)
# Line 576  Line 398 
398                                 'type' => "dom" ,                                 'type' => "dom" ,
399                                 'evalue' => $evalue,                                 'evalue' => $evalue,
400                                 'start' => $from,                                 'start' => $from,
401                                 'stop' => $to                                 'stop' => $to,
402                                   'fig_id' => $fid,
403                                   'score' => $raw_evalue
404                                 };                                 };
405    
406                  push (@{$datasets_ref} ,$dataset);                  push (@{$datasets_ref} ,$dataset);
# Line 585  Line 409 
409      }      }
410  }  }
411    
412  =head3 get_attribute_based_evidence (internal)  sub get_attribute_based_location_observations{
   
 This method retrieves evidence from the attribute server  
413    
414  =cut      my ($fid,$datasets_ref) = (@_);
415        my $fig = new FIG;
416    
417  sub get_attribute_based_observations{      my $location_attributes = ['SignalP','CELLO','TMPRED'];
418    
419      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)      my $dataset = {'type' => "loc",
420      my ($fid,$datasets_ref) = (@_);                     'class' => 'SIGNALP_CELLO_TMPRED',
421                       'fig_id' => $fid
422                       };
423    
424      my $_myfig = new FIG;      foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) {
425            my $key = @$attr_ref[1];
426            my @parts = split("::",$key);
427            my $sub_class = $parts[0];
428            my $sub_key = $parts[1];
429            my $value = @$attr_ref[2];
430            if($sub_class eq "SignalP"){
431                if($sub_key eq "cleavage_site"){
432                    my @value_parts = split(";",$value);
433                    $dataset->{'cleavage_prob'} = $value_parts[0];
434                    $dataset->{'cleavage_loc'} = $value_parts[1];
435                }
436                elsif($sub_key eq "signal_peptide"){
437                    $dataset->{'signal_peptide_score'} = $value;
438                }
439            }
440            elsif($sub_class eq "CELLO"){
441                $dataset->{'cello_location'} = $sub_key;
442                $dataset->{'cello_score'} = $value;
443            }
444            elsif($sub_class eq "TMPRED"){
445                my @value_parts = split(/\;/,$value);
446                $dataset->{'tmpred_score'} = $value_parts[0];
447                $dataset->{'tmpred_locations'} = $value_parts[1];
448            }
449        }
450    
451      foreach my $attr_ref ($_myfig->get_attributes($fid)) {      push (@{$datasets_ref} ,$dataset);
452    
453          # convert the ref into a string for easier handling  }
         my ($string) = "@$attr_ref";  
454    
455  #       print "S:$string\n";  =head3 get_pdb_observations() (internal)
         my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/);  
456    
457          # THIS SHOULD BE DONE ANOTHER WAY FM->TD  This methods sets the type and class for pdb observations
         # 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  
         #  
458    
459          if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) {  =cut
460    
461              # some keys are composite CDD::1233244 or PFAM:PF1233  sub get_pdb_observations{
462        my ($fid,$datasets_ref) = (@_);
463    
464              if ( $key =~ /::/ ) {      my $fig = new FIG;
                 my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/);  
                 $val=$restkey.";".$val;  
                 $key=$firstkey;  
             }  
465    
466              my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ );      foreach my $attr_ref ($fig->get_attributes($fid,'PDB')) {
467    
468              my $evalue= 255;          my $key = @$attr_ref[1];
469              if (defined $raw_evalue) { # some of the tool do not give us an evalue          my($key1,$key2) =split("::",$key);
470            my $value = @$attr_ref[2];
471            my ($evalue,$location) = split(";",$value);
472    
473                  my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/);          if($evalue =~/(\d+)\.(\d+)/){
474                  my ($new_k, $new_exp);              my $part2 = 1000 - $1;
475                my $part1 = $2/100;
476                $evalue = $part1."e-".$part2;
477            }
478    
479                  #          my($start,$stop) =split("-",$location);
                 #  THIS DOES NOT WORK PROPERLY  
                 #  
                 if($raw_evalue =~/(\d+).(\d+)/){  
480    
481  #                   $new_exp = (1000+$expo);          my $url = @$attr_ref[3];
482          #           $new_k = $k / 100;          my $dataset = {'class' => 'PDB',
483                           'type' => 'seq' ,
484                           'acc' => $key2,
485                           'evalue' => $evalue,
486                           'start' => $start,
487                           'stop' => $stop,
488                           'fig_id' => $fid
489                           };
490    
491            push (@{$datasets_ref} ,$dataset);
492                  }                  }
                 $evalue = "0.01"#new_k."e-".$new_exp;  
493              }              }
494    
495              # unroll it all into an array of hashes  =head3 get_cluster_observations() (internal)
496              # this needs to be done differently for different types of observations  
497              my $dataset = [ { name => 'class', value => $key },  This methods sets the type and class for cluster observations
498                              { name => 'acc' , value => $acc},  
499                              { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD  =cut
500                              { name => 'evalue', value => $evalue },  
501                              { name => 'start', value => $from},  sub get_cluster_observations{
502                              { name => 'stop' , value => $to}      my ($fid,$datasets_ref,$scope) = (@_);
                             ];  
503    
504        my $dataset = {'class' => 'CLUSTER',
505                       'type' => 'fc',
506                       'context' => $scope,
507                       'fig_id' => $fid
508                       };
509              push (@{$datasets_ref} ,$dataset);              push (@{$datasets_ref} ,$dataset);
510          }          }
511      }  
 }  
512    
513  =head3 get_sims_observations() (internal)  =head3 get_sims_observations() (internal)
514    
# Line 667  Line 520 
520    
521      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
522      my $fig = new FIG;      my $fig = new FIG;
523  #    my @sims= $fig->nsims($fid,100,1e-20,"fig");      my @sims= $fig->nsims($fid,500,1e-20,"all");
     my @sims= $fig->nsims($fid,100,1e-20,"all");  
524      my ($dataset);      my ($dataset);
525    
526        my %id_list;
527        foreach my $sim (@sims){
528            my $hit = $sim->[1];
529    
530            next if ($hit !~ /^fig\|/);
531            my @aliases = $fig->feature_aliases($hit);
532            foreach my $alias (@aliases){
533                $id_list{$alias} = 1;
534            }
535        }
536    
537        my %already;
538        my (@new_sims, @uniprot);
539      foreach my $sim (@sims){      foreach my $sim (@sims){
540          my $hit = $sim->[1];          my $hit = $sim->[1];
541            my ($id) = ($hit) =~ /\|(.*)/;
542            next if (defined($already{$id}));
543            next if (defined($id_list{$hit}));
544            push (@new_sims, $sim);
545            $already{$id} = 1;
546        }
547    
548        foreach my $sim (@new_sims){
549            my $hit = $sim->[1];
550          my $percent = $sim->[2];          my $percent = $sim->[2];
551          my $evalue = $sim->[10];          my $evalue = $sim->[10];
552          my $qfrom = $sim->[6];          my $qfrom = $sim->[6];
# Line 697  Line 572 
572                      'organism' => $organism,                      'organism' => $organism,
573                      'function' => $func,                      'function' => $func,
574                      'qlength' => $qlength,                      'qlength' => $qlength,
575                      'hlength' => $hlength                      'hlength' => $hlength,
576                        'fig_id' => $fid
577                      };                      };
578    
579          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
# Line 729  Line 605 
605    
606  }  }
607    
608    
609  =head3 get_identical_proteins() (internal)  =head3 get_identical_proteins() (internal)
610    
611  This methods retrieves sims fills the internal data structures.  This methods retrieves sims fills the internal data structures.
# Line 739  Line 616 
616    
617      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
618      my $fig = new FIG;      my $fig = new FIG;
619      my @funcs = ();      my $funcs_ref;
620    
621        my %id_list;
622      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);
623        my @aliases = $fig->feature_aliases($fid);
624        foreach my $alias (@aliases){
625            $id_list{$alias} = 1;
626        }
627    
628      foreach my $id (@maps_to) {      foreach my $id (@maps_to) {
629          my ($tmp, $who);          my ($tmp, $who);
630          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {          if (($id ne $fid) && ($tmp = $fig->function_of($id)) && (! defined ($id_list{$id}))) {
631              $who = &get_database($id);              $who = &get_database($id);
632              push(@funcs, [$id,$who,$tmp]);              push(@$funcs_ref, [$id,$who,$tmp]);
633          }          }
634      }      }
635    
636      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];  
   
637          my $dataset = {'class' => 'IDENTICAL',          my $dataset = {'class' => 'IDENTICAL',
                        'id' => $id,  
                        'organism' => $organism,  
638                         'type' => 'seq',                         'type' => 'seq',
639                         'database' => $who,                     'fig_id' => $fid,
640                         'function' => $assignment                     'rows' => $funcs_ref
641                         };                         };
642    
643          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
644      }  
645    
646  }  }
647    
# Line 798  Line 672 
672                    } @fc_data;                    } @fc_data;
673    
674      my ($dataset);      my ($dataset);
     foreach my $row (@rows){  
         my $id = $row->[1];  
         my $score = $row->[0];  
         my $description = $row->[2];  
675          my $dataset = {'class' => 'PCH',          my $dataset = {'class' => 'PCH',
                        'score' => $score,  
                        'id' => $id,  
676                         'type' => 'fc',                         'type' => 'fc',
677                         'function' => $description                     'fig_id' => $fid,
678                       'rows' => \@rows
679                         };                         };
680    
681          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";  
 #       }  
   
 #     }  
   
682    
683    }
684    
685  =head3 new (internal)  =head3 new (internal)
686    
# Line 867  Line 691 
691  sub new {  sub new {
692    my ($class,$dataset) = @_;    my ($class,$dataset) = @_;
693    
   
   #$self = { acc => '',  
 #           description => '',  
 #           class => '',  
 #           type => '',  
 #           start => '',  
 #           stop => '',  
 #           evalue => '',  
 #           score => '',  
 #           display_method => '',  
 #           feature_id => '',  
 #           rank => '',  
 #           supports_annotation => '',  
 #           id => '',  
 #            organism => '',  
 #            who => ''  
 #         };  
   
694    my $self = { class => $dataset->{'class'},    my $self = { class => $dataset->{'class'},
695                 type => $dataset->{'type'}                 type => $dataset->{'type'},
696                   fig_id => $dataset->{'fig_id'},
697                   score => $dataset->{'score'},
698             };             };
699    
700    bless($self,$class);    bless($self,$class);
# Line 906  Line 714 
714      return $self->{identity};      return $self->{identity};
715  }  }
716    
717    =head3 fig_id (internal)
718    
719    =cut
720    
721    sub fig_id {
722      my ($self) = @_;
723      return $self->{fig_id};
724    }
725    
726  =head3 feature_id (internal)  =head3 feature_id (internal)
727    
728    
# Line 965  Line 782 
782      return $self->{database};      return $self->{database};
783  }  }
784    
785    sub score {
786      my ($self) = @_;
787    
788      return $self->{score};
789    }
790    
791  ############################################################  ############################################################
792  ############################################################  ############################################################
793  package Observation::Identical;  package Observation::PDB;
794    
795  use base qw(Observation);  use base qw(Observation);
796    
# Line 977  Line 798 
798    
799      my ($class,$dataset) = @_;      my ($class,$dataset) = @_;
800      my $self = $class->SUPER::new($dataset);      my $self = $class->SUPER::new($dataset);
801      $self->{id} = $dataset->{'id'};      $self->{acc} = $dataset->{'acc'};
802      $self->{organism} = $dataset->{'organism'};      $self->{evalue} = $dataset->{'evalue'};
803      $self->{function} = $dataset->{'function'};      $self->{start} = $dataset->{'start'};
804      $self->{database} = $dataset->{'database'};      $self->{stop} = $dataset->{'stop'};
   
805      bless($self,$class);      bless($self,$class);
806      return $self;      return $self;
807  }  }
808    
809  =head3 display()  =head3 display()
810    
811  If available use the function specified here to display the "raw" observation.  displays data stored in best_PDB attribute and in Ontology server for given PDB id
 This code will display a table for the identical protein  
   
   
 B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evi  
 dence.  
812    
813  =cut  =cut
814    
815  sub display{  sub display{
816      my ($self, $cgi, $dataset) = @_;      my ($self,$gd) = @_;
817    
818      my $all_domains = [];      my $fid = $self->fig_id;
819      my $count_identical = 0;      my $dbmaster = DBMaster->new(-database =>'Ontology');
     my $content;  
     foreach my $thing (@$dataset) {  
         next if ($thing->class ne "IDENTICAL");  
         my $single_domain = [];  
         push(@$single_domain,$thing->database);  
         my $id = $thing->id;  
         $count_identical++;  
         push(@$single_domain,&HTML::set_prot_links($cgi,$id));  
         push(@$single_domain,$thing->organism);  
         #push(@$single_domain,$thing->type);  
         push(@$single_domain,$thing->function);  
         push(@$all_domains,$single_domain);  
     }  
820    
821      if ($count_identical >0){      my $acc = $self->acc;
822          $content = $all_domains;  
823        my ($pdb_description,$pdb_source,$pdb_ligand);
824        my $pdb_objs = $dbmaster->pdb->get_objects( { 'id' => $acc } );
825        if(!scalar(@$pdb_objs)){
826            $pdb_description = "not available";
827            $pdb_source = "not available";
828            $pdb_ligand = "not available";
829      }      }
830      else{      else{
831          $content = "<p>This PEG does not have any essentially identical proteins</p>";          my $pdb_obj = $pdb_objs->[0];
832      }          $pdb_description = $pdb_obj->description;
833      return ($content);          $pdb_source = $pdb_obj->source;
834            $pdb_ligand = $pdb_obj->ligand;
835  }  }
836    
837  1;      my $lines = [];
838        my $line_data = [];
839        my $line_config = { 'title' => "PDB hit for $fid",
840                            'short_title' => "best PDB",
841                            'basepair_offset' => '1' };
842    
843        my $fig = new FIG;
844        my $seq = $fig->get_translation($fid);
845        my $fid_stop = length($seq);
846    
847  #########################################      my $fid_element_hash = {
848  #########################################          "title" => $fid,
849  package Observation::FC;          "start" => '1',
850  1;          "end" =>  $fid_stop,
851            "color"=> '1',
852            "zlayer" => '1'
853            };
854    
855  use base qw(Observation);      push(@$line_data,$fid_element_hash);
856    
857        my $links_list = [];
858        my $descriptions = [];
859    
860        my $name;
861        $name = {"title" => 'id',
862                 "value" => $acc};
863        push(@$descriptions,$name);
864    
865        my $description;
866        $description = {"title" => 'pdb description',
867                        "value" => $pdb_description};
868        push(@$descriptions,$description);
869    
870        my $score;
871        $score = {"title" => "score",
872                  "value" => $self->evalue};
873        push(@$descriptions,$score);
874    
875        my $start_stop;
876        my $start_stop_value = $self->start."_".$self->stop;
877        $start_stop = {"title" => "start-stop",
878                       "value" => $start_stop_value};
879        push(@$descriptions,$start_stop);
880    
881        my $source;
882        $source = {"title" => "source",
883                  "value" => $pdb_source};
884        push(@$descriptions,$source);
885    
886        my $ligand;
887        $ligand = {"title" => "pdb ligand",
888                   "value" => $pdb_ligand};
889        push(@$descriptions,$ligand);
890    
891        my $link;
892        my $link_url ="http://www.rcsb.org/pdb/explore/explore.do?structureId=".$acc;
893    
894        $link = {"link_title" => $acc,
895                 "link" => $link_url};
896        push(@$links_list,$link);
897    
898        my $pdb_element_hash = {
899            "title" => "PDB homology",
900            "start" => $self->start,
901            "end" =>  $self->stop,
902            "color"=> '6',
903            "zlayer" => '3',
904            "links_list" => $links_list,
905            "description" => $descriptions};
906    
907        push(@$line_data,$pdb_element_hash);
908        $gd->add_line($line_data, $line_config);
909    
910        return $gd;
911    }
912    
913    1;
914    
915    ############################################################
916    ############################################################
917    package Observation::Identical;
918    
919    use base qw(Observation);
920    
921  sub new {  sub new {
922    
923      my ($class,$dataset) = @_;      my ($class,$dataset) = @_;
924      my $self = $class->SUPER::new($dataset);      my $self = $class->SUPER::new($dataset);
925      $self->{score} = $dataset->{'score'};      $self->{rows} = $dataset->{'rows'};
     $self->{id} = $dataset->{'id'};  
     $self->{function} = $dataset->{'function'};  
926    
927      bless($self,$class);      bless($self,$class);
928      return $self;      return $self;
929  }  }
930    
931  =head3 display()  =head3 display_table()
932    
933  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
934  This code will display a table for the identical protein  This code will display a table for the identical protein
# Line 1058  Line 939 
939    
940  =cut  =cut
941    
 sub display {  
     my ($self,$cgi,$dataset, $fid) = @_;  
942    
943    sub display_table{
944        my ($self) = @_;
945    
946        my $fig = new FIG;
947        my $fid = $self->fig_id;
948        my $rows = $self->rows;
949        my $cgi = new CGI;
950        my $all_domains = [];
951        my $count_identical = 0;
952        my $content;
953        foreach my $row (@$rows) {
954            my $id = $row->[0];
955            my $who = $row->[1];
956            my $assignment = $row->[2];
957            my $organism = $fig->org_of($id);
958            my $single_domain = [];
959            push(@$single_domain,$who);
960            push(@$single_domain,&HTML::set_prot_links($cgi,$id));
961            push(@$single_domain,$organism);
962            push(@$single_domain,$assignment);
963            push(@$all_domains,$single_domain);
964            $count_identical++;
965        }
966    
967        if ($count_identical >0){
968            $content = $all_domains;
969        }
970        else{
971            $content = "<p>This PEG does not have any essentially identical proteins</p>";
972        }
973        return ($content);
974    }
975    
976    1;
977    
978    #########################################
979    #########################################
980    package Observation::FC;
981    1;
982    
983    use base qw(Observation);
984    
985    sub new {
986    
987        my ($class,$dataset) = @_;
988        my $self = $class->SUPER::new($dataset);
989        $self->{rows} = $dataset->{'rows'};
990    
991        bless($self,$class);
992        return $self;
993    }
994    
995    =head3 display_table()
996    
997    If available use the function specified here to display the "raw" observation.
998    This code will display a table for the identical protein
999    
1000    
1001    B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evi
1002    dence.
1003    
1004    =cut
1005    
1006    sub display_table {
1007    
1008        my ($self,$dataset) = @_;
1009        my $fid = $self->fig_id;
1010        my $rows = $self->rows;
1011        my $cgi = new CGI;
1012      my $functional_data = [];      my $functional_data = [];
1013      my $count = 0;      my $count = 0;
1014      my $content;      my $content;
1015    
1016      foreach my $thing (@$dataset) {      foreach my $row (@$rows) {
1017          my $single_domain = [];          my $single_domain = [];
         next if ($thing->class ne "PCH");  
1018          $count++;          $count++;
1019    
1020          # construct the score link          # construct the score link
1021          my $score = $thing->score;          my $score = $row->[0];
1022          my $toid = $thing->id;          my $toid = $row->[1];
1023          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=";
1024          my $sc_link = "<a href=$link>$score</a>";          my $sc_link = "<a href=$link>$score</a>";
1025    
1026          push(@$single_domain,$sc_link);          push(@$single_domain,$sc_link);
1027          push(@$single_domain,$thing->id);          push(@$single_domain,$row->[1]);
1028          push(@$single_domain,$thing->function);          push(@$single_domain,$row->[2]);
1029          push(@$functional_data,$single_domain);          push(@$functional_data,$single_domain);
1030      }      }
1031    
# Line 1124  Line 1071 
1071      my $links_list = [];      my $links_list = [];
1072      my $descriptions = [];      my $descriptions = [];
1073    
1074      my $description_function;      my $db_and_id = $thing->acc;
1075      $description_function = {"title" => $thing->class,      my ($db,$id) = split("::",$db_and_id);
                              "value" => $thing->acc};  
1076    
1077      push(@$descriptions,$description_function);      my $dbmaster = DBMaster->new(-database =>'Ontology');
1078    
1079        my ($name_title,$name_value,$description_title,$description_value);
1080        if($db eq "CDD"){
1081            my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1082            if(!scalar(@$cdd_objs)){
1083                $name_title = "name";
1084                $name_value = "not available";
1085                $description_title = "description";
1086                $description_value = "not available";
1087            }
1088            else{
1089                my $cdd_obj = $cdd_objs->[0];
1090                $name_title = "name";
1091                $name_value = $cdd_obj->term;
1092                $description_title = "description";
1093                $description_value = $cdd_obj->description;
1094            }
1095        }
1096    
1097        my $name;
1098        $name = {"title" => $name_title,
1099                 "value" => $name_value};
1100        push(@$descriptions,$name);
1101    
1102        my $description;
1103        $description = {"title" => $description_title,
1104                                 "value" => $description_value};
1105        push(@$descriptions,$description);
1106    
1107      my $score;      my $score;
1108      $score = {"title" => "score",      $score = {"title" => "score",
# Line 1136  Line 1110 
1110      push(@$descriptions,$score);      push(@$descriptions,$score);
1111    
1112      my $link_id;      my $link_id;
1113      if ($thing->acc =~/CDD::(\d+)/){      if ($thing->acc =~/\w+::(\d+)/){
1114          $link_id = $1;          $link_id = $1;
1115      }      }
1116    
1117      my $link;      my $link;
1118        my $link_url;
1119        if ($thing->class eq "CDD"){$link_url = "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"}
1120        elsif($thing->class eq "PFAM"){$link_url = "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?$link_id"}
1121        else{$link_url = "NO_URL"}
1122    
1123      $link = {"link_title" => $thing->acc,      $link = {"link_title" => $thing->acc,
1124               "link" => "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"};               "link" => $link_url};
1125      push(@$links_list,$link);      push(@$links_list,$link);
1126    
1127      my $element_hash = {      my $element_hash = {
# Line 1163  Line 1142 
1142    
1143  #########################################  #########################################
1144  #########################################  #########################################
1145    package Observation::Location;
1146    
1147    use base qw(Observation);
1148    
1149    sub new {
1150    
1151        my ($class,$dataset) = @_;
1152        my $self = $class->SUPER::new($dataset);
1153        $self->{cleavage_prob} = $dataset->{'cleavage_prob'};
1154        $self->{cleavage_loc} = $dataset->{'cleavage_loc'};
1155        $self->{signal_peptide_score} = $dataset->{'signal_peptide_score'};
1156        $self->{cello_location} = $dataset->{'cello_location'};
1157        $self->{cello_score} = $dataset->{'cello_score'};
1158        $self->{tmpred_score} = $dataset->{'tmpred_score'};
1159        $self->{tmpred_locations} = $dataset->{'tmpred_locations'};
1160    
1161        bless($self,$class);
1162        return $self;
1163    }
1164    
1165    sub display {
1166        my ($thing,$gd) = @_;
1167    
1168        my $fid = $thing->fig_id;
1169        my $fig= new FIG;
1170        my $length = length($fig->get_translation($fid));
1171    
1172        my $cleavage_prob;
1173        if($thing->cleavage_prob){$cleavage_prob = $thing->cleavage_prob;}
1174        my ($cleavage_loc_begin,$cleavage_loc_end) = split("-",$thing->cleavage_loc);
1175        my $signal_peptide_score = $thing->signal_peptide_score;
1176        my $cello_location = $thing->cello_location;
1177        my $cello_score = $thing->cello_score;
1178        my $tmpred_score = $thing->tmpred_score;
1179        my @tmpred_locations = split(",",$thing->tmpred_locations);
1180    
1181        my $lines = [];
1182        my $line_config = { 'title' => 'Localization Evidence',
1183                            'short_title' => 'Local',
1184                            'basepair_offset' => '1' };
1185    
1186        #color is
1187        my $color = "5";
1188    
1189        my $line_data = [];
1190    
1191        if($cello_location){
1192            my $cello_descriptions = [];
1193            my $description_cello_location = {"title" => 'Best Cello Location',
1194                                              "value" => $cello_location};
1195    
1196            push(@$cello_descriptions,$description_cello_location);
1197    
1198            my $description_cello_score = {"title" => 'Cello Score',
1199                                           "value" => $cello_score};
1200    
1201            push(@$cello_descriptions,$description_cello_score);
1202    
1203            my $element_hash = {
1204                "title" => "CELLO",
1205                "start" => "1",
1206                "end" =>  $length + 1,
1207                "color"=> $color,
1208                "type" => 'box',
1209                "zlayer" => '2',
1210                "description" => $cello_descriptions};
1211    
1212            push(@$line_data,$element_hash);
1213        }
1214    
1215        my $color = "6";
1216        if($tmpred_score){
1217            foreach my $tmpred (@tmpred_locations){
1218                my $descriptions = [];
1219                my ($begin,$end) =split("-",$tmpred);
1220                my $description_tmpred_score = {"title" => 'TMPRED score',
1221                                 "value" => $tmpred_score};
1222    
1223                push(@$descriptions,$description_tmpred_score);
1224    
1225                my $element_hash = {
1226                "title" => "transmembrane location",
1227                "start" => $begin + 1,
1228                "end" =>  $end + 1,
1229                "color"=> $color,
1230                "zlayer" => '5',
1231                "type" => 'smallbox',
1232                "description" => $descriptions};
1233    
1234                push(@$line_data,$element_hash);
1235            }
1236        }
1237    
1238        my $color = "1";
1239        if($signal_peptide_score){
1240            my $descriptions = [];
1241            my $description_signal_peptide_score = {"title" => 'signal peptide score',
1242                                                    "value" => $signal_peptide_score};
1243    
1244            push(@$descriptions,$description_signal_peptide_score);
1245    
1246            my $description_cleavage_prob = {"title" => 'cleavage site probability',
1247                                             "value" => $cleavage_prob};
1248    
1249            push(@$descriptions,$description_cleavage_prob);
1250    
1251            my $element_hash = {
1252                "title" => "SignalP",
1253                "start" => $cleavage_loc_begin - 2,
1254                "end" =>  $cleavage_loc_end + 3,
1255                "type" => 'bigbox',
1256                "color"=> $color,
1257                "zlayer" => '10',
1258                "description" => $descriptions};
1259    
1260            push(@$line_data,$element_hash);
1261        }
1262    
1263        $gd->add_line($line_data, $line_config);
1264    
1265        return ($gd);
1266    
1267    }
1268    
1269    sub cleavage_loc {
1270      my ($self) = @_;
1271    
1272      return $self->{cleavage_loc};
1273    }
1274    
1275    sub cleavage_prob {
1276      my ($self) = @_;
1277    
1278      return $self->{cleavage_prob};
1279    }
1280    
1281    sub signal_peptide_score {
1282      my ($self) = @_;
1283    
1284      return $self->{signal_peptide_score};
1285    }
1286    
1287    sub tmpred_score {
1288      my ($self) = @_;
1289    
1290      return $self->{tmpred_score};
1291    }
1292    
1293    sub tmpred_locations {
1294      my ($self) = @_;
1295    
1296      return $self->{tmpred_locations};
1297    }
1298    
1299    sub cello_location {
1300      my ($self) = @_;
1301    
1302      return $self->{cello_location};
1303    }
1304    
1305    sub cello_score {
1306      my ($self) = @_;
1307    
1308      return $self->{cello_score};
1309    }
1310    
1311    
1312    #########################################
1313    #########################################
1314  package Observation::Sims;  package Observation::Sims;
1315    
1316  use base qw(Observation);  use base qw(Observation);
# Line 1190  Line 1338 
1338    
1339  =head3 display()  =head3 display()
1340    
1341    If available use the function specified here to display a graphical observation.
1342    This code will display a graphical view of the similarities using the genome drawer object
1343    
1344    =cut
1345    
1346    sub display {
1347        my ($self,$gd) = @_;
1348    
1349        my $fig = new FIG;
1350        my $peg = $self->acc;
1351    
1352        my $organism = $self->organism;
1353        my $function = $self->function;
1354        my $abbrev_name = $fig->abbrev($organism);
1355        my $align_start = $self->qstart;
1356        my $align_stop = $self->qstop;
1357        my $hit_start = $self->hstart;
1358        my $hit_stop = $self->hstop;
1359    
1360        my $line_config = { 'title' => "$organism",
1361                            'short_title' => "$abbrev_name",
1362                            'basepair_offset' => '0'
1363                            };
1364    
1365        my $line_data = [];
1366    
1367        my $element_hash;
1368        my $links_list = [];
1369        my $descriptions = [];
1370    
1371        # get subsystem information
1372        my $url_link = "http://seed-viewer.theseed.org/index.cgi?action=ShowAnnotation&prot=".$peg;
1373    
1374        my $link;
1375        $link = {"link_title" => $peg,
1376                 "link" => $url_link};
1377        push(@$links_list,$link);
1378    
1379        my @subsystems = $fig->peg_to_subsystems($peg);
1380        foreach my $subsystem (@subsystems){
1381            my $link;
1382            $link = {"link" => "http://seed-viewer.theseed.org/index.cgi?action=ShowSubsystem&subsystem_name=$subsystem",
1383                     "link_title" => $subsystem};
1384            push(@$links_list,$link);
1385        }
1386    
1387        my $description_function;
1388        $description_function = {"title" => "function",
1389                                 "value" => $function};
1390        push(@$descriptions,$description_function);
1391    
1392        my ($description_ss, $ss_string);
1393        $ss_string = join (",", @subsystems);
1394        $description_ss = {"title" => "subsystems",
1395                           "value" => $ss_string};
1396        push(@$descriptions,$description_ss);
1397    
1398        my $description_loc;
1399        $description_loc = {"title" => "location start",
1400                            "value" => $hit_start};
1401        push(@$descriptions, $description_loc);
1402    
1403        $description_loc = {"title" => "location stop",
1404                            "value" => $hit_stop};
1405        push(@$descriptions, $description_loc);
1406    
1407        my $evalue = $self->evalue;
1408        while ($evalue =~ /-0/)
1409        {
1410            my ($chunk1, $chunk2) = split(/-/, $evalue);
1411            $chunk2 = substr($chunk2,1);
1412            $evalue = $chunk1 . "-" . $chunk2;
1413        }
1414    
1415        my $color = &color($evalue);
1416    
1417        my $description_eval = {"title" => "E-Value",
1418                                "value" => $evalue};
1419        push(@$descriptions, $description_eval);
1420    
1421        my $identity = $self->identity;
1422        my $description_identity = {"title" => "Identity",
1423                                    "value" => $identity};
1424        push(@$descriptions, $description_identity);
1425    
1426        $element_hash = {
1427            "title" => $peg,
1428            "start" => $align_start,
1429            "end" =>  $align_stop,
1430            "type"=> 'box',
1431            "color"=> $color,
1432            "zlayer" => "2",
1433            "links_list" => $links_list,
1434            "description" => $descriptions
1435            };
1436        push(@$line_data,$element_hash);
1437        $gd->add_line($line_data, $line_config);
1438    
1439        return ($gd);
1440    
1441    }
1442    
1443    =head3 display_table()
1444    
1445  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
1446  This code will display a table for the similarities protein  This code will display a table for the similarities protein
1447    
# Line 1197  Line 1449 
1449    
1450  =cut  =cut
1451    
1452  sub display {  sub display_table {
1453      my ($self,$cgi,$dataset) = @_;      my ($self,$dataset) = @_;
1454    
1455      my $data = [];      my $data = [];
1456      my $count = 0;      my $count = 0;
1457      my $content;      my $content;
1458      my $fig = new FIG;      my $fig = new FIG;
1459        my $cgi = new CGI;
1460      foreach my $thing (@$dataset) {      foreach my $thing (@$dataset) {
1461          my $single_domain = [];          my $single_domain = [];
1462          next if ($thing->class ne "SIM");          next if ($thing->class ne "SIM");
# Line 1250  Line 1502 
1502                                      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));
1503          }          }
1504    
         # add the aliases  
         my $aliases = undef;  
         $aliases = &html_enc( join( ", ", $fig->feature_aliases($id) ) );  
         $aliases = &HTML::set_prot_links( $cgi, $aliases );  
         $aliases ||= "&nbsp;";  
   
1505          my $iden    = $thing->identity;          my $iden    = $thing->identity;
1506          my $ln1     = $thing->qlength;          my $ln1     = $thing->qlength;
1507          my $ln2     = $thing->hlength;          my $ln2     = $thing->hlength;
# Line 1268  Line 1514 
1514          my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";          my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";
1515          my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";          my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";
1516    
1517            my $name = $thing->acc;
1518            my $field_name = "tables_" . $name;
1519            my $pair_name = "visual_" . $name;
1520    
1521            my $checkbox_col = qq(<input type=checkbox name=seq value="$name" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
1522            my $acc_col .= &HTML::set_prot_links($cgi,$thing->acc);
1523    
1524            push(@$single_domain,$checkbox_col);
1525          push(@$single_domain,$thing->database);          push(@$single_domain,$thing->database);
1526          push(@$single_domain,&HTML::set_prot_links($cgi,$thing->acc));          push(@$single_domain,$acc_col);
1527          push(@$single_domain,$thing->evalue);          push(@$single_domain,$thing->evalue);
1528          push(@$single_domain,"$iden\%");          push(@$single_domain,"$iden\%");
1529          push(@$single_domain,$reg1);          push(@$single_domain,$reg1);
# Line 1279  Line 1532 
1532          push(@$single_domain,$ev_codes);          push(@$single_domain,$ev_codes);
1533          push(@$single_domain,$thing->organism);          push(@$single_domain,$thing->organism);
1534          push(@$single_domain,$thing->function);          push(@$single_domain,$thing->function);
         push(@$single_domain,$aliases);  
1535          push(@$data,$single_domain);          push(@$data,$single_domain);
1536    
1537      }      }
1538    
1539      if ($count >0){      if ($count >0){
1540          $content = $data;          $content = $data;
1541      }      }
1542      else      else{
     {  
1543          $content = "<p>This PEG does not have any similarities</p>";          $content = "<p>This PEG does not have any similarities</p>";
1544      }      }
1545      return ($content);      return ($content);
1546  }  }
1547    
1548  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; $_ }
1549    
1550    sub color {
1551        my ($evalue) = @_;
1552    
1553        my $color;
1554        if ($evalue <= 1e-100){
1555            $color = 1;
1556        }
1557        elsif (($evalue <= 1e-70) && ($evalue > 1e-100)){
1558            $color = 2;
1559        }
1560        elsif (($evalue <= 1e-20) && ($evalue > 1e-70)){
1561            $color = 3;
1562        }
1563        elsif (($evalue <= 1e-10) && ($evalue > 1e-20)){
1564            $color = 4;
1565        }
1566        elsif (($evalue <= 1e-4) && ($evalue > 1e-1)){
1567            $color = 5;
1568        }
1569        else{
1570            $color = 6;
1571        }
1572        return ($color);
1573    }
1574    
1575    
1576    ############################
1577    package Observation::Cluster;
1578    
1579    use base qw(Observation);
1580    
1581    sub new {
1582    
1583        my ($class,$dataset) = @_;
1584        my $self = $class->SUPER::new($dataset);
1585        $self->{context} = $dataset->{'context'};
1586        bless($self,$class);
1587        return $self;
1588    }
1589    
1590    sub display {
1591        my ($self,$gd) = @_;
1592    
1593        my $fid = $self->fig_id;
1594        my $compare_or_coupling = $self->context;
1595        my $gd_window_size = $gd->window_size;
1596        my $fig = new FIG;
1597        my $all_regions = [];
1598    
1599        #get the organism genome
1600        my $target_genome = $fig->genome_of($fid);
1601    
1602        # get location of the gene
1603        my $data = $fig->feature_location($fid);
1604        my ($contig, $beg, $end);
1605        my %reverse_flag;
1606    
1607        if ($data =~ /(.*)_(\d+)_(\d+)$/){
1608            $contig = $1;
1609            $beg = $2;
1610            $end = $3;
1611        }
1612    
1613        my $offset;
1614        my ($region_start, $region_end);
1615        if ($beg < $end)
1616        {
1617            $region_start = $beg - 4000;
1618            $region_end = $end+4000;
1619            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
1620        }
1621        else
1622        {
1623            $region_start = $end-4000;
1624            $region_end = $beg+4000;
1625            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
1626            $reverse_flag{$target_genome} = $fid;
1627        }
1628    
1629        # call genes in region
1630        my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_end);
1631        push(@$all_regions,$target_gene_features);
1632        my (@start_array_region);
1633        push (@start_array_region, $offset);
1634    
1635        my %all_genes;
1636        my %all_genomes;
1637        foreach my $feature (@$target_gene_features){ $all_genes{$feature} = $fid;}
1638    
1639        if ($compare_or_coupling eq "diverse")
1640        {
1641            my @coup = grep { $_->[1]} $fig->coupling_and_evidence($fid,5000,1e-10,4,1);
1642    
1643            my $coup_count = 0;
1644    
1645            foreach my $pair (@{$coup[0]->[2]}) {
1646                #   last if ($coup_count > 10);
1647                my ($peg1,$peg2) = @$pair;
1648    
1649                my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome);
1650                $pair_genome = $fig->genome_of($peg1);
1651    
1652                my $location = $fig->feature_location($peg1);
1653                if($location =~/(.*)_(\d+)_(\d+)$/){
1654                    $pair_contig = $1;
1655                    $pair_beg = $2;
1656                    $pair_end = $3;
1657                    if ($pair_beg < $pair_end)
1658                    {
1659                        $pair_region_start = $pair_beg - 4000;
1660                        $pair_region_stop = $pair_end+4000;
1661                        $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
1662                    }
1663                    else
1664                    {
1665                        $pair_region_start = $pair_end-4000;
1666                        $pair_region_stop = $pair_beg+4000;
1667                        $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
1668                        $reverse_flag{$pair_genome} = $peg1;
1669                    }
1670    
1671                    push (@start_array_region, $offset);
1672    
1673                    $all_genomes{$pair_genome} = 1;
1674                    my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop);
1675                    push(@$all_regions,$pair_features);
1676                    foreach my $pair_feature (@$pair_features){ $all_genes{$pair_feature} = $peg1;}
1677                }
1678                $coup_count++;
1679            }
1680        }
1681    
1682        elsif ($compare_or_coupling eq "close")
1683        {
1684            # make a hash of genomes that are phylogenetically close
1685            #my $close_threshold = ".26";
1686            #my @genomes = $fig->genomes('complete');
1687            #my %close_genomes = ();
1688            #foreach my $compared_genome (@genomes)
1689            #{
1690            #    my $dist = $fig->crude_estimate_of_distance($target_genome,$compared_genome);
1691            #    #$close_genomes{$compared_genome} = $dist;
1692            #    if ($dist <= $close_threshold)
1693            #    {
1694            #       $all_genomes{$compared_genome} = 1;
1695            #    }
1696            #}
1697            $all_genomes{"216592.1"} = 1;
1698            $all_genomes{"79967.1"} = 1;
1699            $all_genomes{"199310.1"} = 1;
1700            $all_genomes{"216593.1"} = 1;
1701            $all_genomes{"155864.1"} = 1;
1702            $all_genomes{"83334.1"} = 1;
1703            $all_genomes{"316407.3"} = 1;
1704    
1705            foreach my $comp_genome (keys %all_genomes){
1706                my $return = $fig->bbh_list($comp_genome,[$fid]);
1707                my $feature_list = $return->{$fid};
1708                foreach my $peg1 (@$feature_list){
1709                    my $location = $fig->feature_location($peg1);
1710                    my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome);
1711                    $pair_genome = $fig->genome_of($peg1);
1712    
1713                    if($location =~/(.*)_(\d+)_(\d+)$/){
1714                        $pair_contig = $1;
1715                        $pair_beg = $2;
1716                        $pair_end = $3;
1717                        if ($pair_beg < $pair_end)
1718                        {
1719                            $pair_region_start = $pair_beg - 4000;
1720                            $pair_region_stop = $pair_end + 4000;
1721                            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
1722                        }
1723                        else
1724                        {
1725                            $pair_region_start = $pair_end-4000;
1726                            $pair_region_stop = $pair_beg+4000;
1727                            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
1728                            $reverse_flag{$pair_genome} = $peg1;
1729                        }
1730    
1731                        push (@start_array_region, $offset);
1732                        $all_genomes{$pair_genome} = 1;
1733                        my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop);
1734                        push(@$all_regions,$pair_features);
1735                        foreach my $pair_feature (@$pair_features){ $all_genes{$pair_feature} = $peg1;}
1736                    }
1737                }
1738            }
1739        }
1740    
1741        # get the PCH to each of the genes
1742        my $pch_sets = [];
1743        my %pch_already;
1744        foreach my $gene_peg (keys %all_genes)
1745        {
1746            if ($pch_already{$gene_peg}){next;};
1747            my $gene_set = [$gene_peg];
1748            foreach my $pch_peg ($fig->in_pch_pin_with($gene_peg)) {
1749                $pch_peg =~ s/,.*$//;
1750                my $pch_genome = $fig->genome_of($pch_peg);
1751                if ( ($gene_peg ne $pch_peg) && ($all_genomes{$pch_genome})) {
1752                    push(@$gene_set,$pch_peg);
1753                    $pch_already{$pch_peg}=1;
1754                }
1755                $pch_already{$gene_peg}=1;
1756            }
1757            push(@$pch_sets,$gene_set);
1758        }
1759    
1760        #create a rank of the pch's
1761        my %pch_set_rank;
1762        my $order = 0;
1763        foreach my $set (@$pch_sets){
1764            my $count = scalar(@$set);
1765            $pch_set_rank{$order} = $count;
1766            $order++;
1767        }
1768    
1769        my %peg_rank;
1770        my $counter =  1;
1771        foreach my $pch_order (sort {$pch_set_rank{$b} <=> $pch_set_rank{$a}} keys %pch_set_rank){
1772            my $good_set = @$pch_sets[$pch_order];
1773            my $flag_set = 0;
1774            if (scalar (@$good_set) > 1)
1775            {
1776                foreach my $peg (@$good_set){
1777                    if ((!$peg_rank{$peg})){
1778                        $peg_rank{$peg} = $counter;
1779                        $flag_set = 1;
1780                    }
1781                }
1782                $counter++ if ($flag_set == 1);
1783            }
1784            else
1785            {
1786                foreach my $peg (@$good_set){
1787                    $peg_rank{$peg} = "20";
1788                }
1789            }
1790        }
1791    
1792    
1793    #    my $bbh_sets = [];
1794    #    my %already;
1795    #    foreach my $gene_key (keys(%all_genes)){
1796    #       if($already{$gene_key}){next;}
1797    #       my $gene_set = [$gene_key];
1798    #
1799    #       my $gene_key_genome = $fig->genome_of($gene_key);
1800    #
1801    #       foreach my $genome_key (keys(%all_genomes)){
1802    #           #next if ($gene_key_genome eq $genome_key);
1803    #           my $return = $fig->bbh_list($genome_key,[$gene_key]);
1804    #
1805    #           my $feature_list = $return->{$gene_key};
1806    #           foreach my $fl (@$feature_list){
1807    #               push(@$gene_set,$fl);
1808    #           }
1809    #       }
1810    #       $already{$gene_key} = 1;
1811    #       push(@$bbh_sets,$gene_set);
1812    #    }
1813    #
1814    #    my %bbh_set_rank;
1815    #    my $order = 0;
1816    #    foreach my $set (@$bbh_sets){
1817    #       my $count = scalar(@$set);
1818    #       $bbh_set_rank{$order} = $count;
1819    #       $order++;
1820    #    }
1821    #
1822    #    my %peg_rank;
1823    #    my $counter =  1;
1824    #    foreach my $bbh_order (sort {$bbh_set_rank{$b} <=> $bbh_set_rank{$a}} keys %bbh_set_rank){
1825    #       my $good_set = @$bbh_sets[$bbh_order];
1826    #       my $flag_set = 0;
1827    #       if (scalar (@$good_set) > 1)
1828    #       {
1829    #           foreach my $peg (@$good_set){
1830    #               if ((!$peg_rank{$peg})){
1831    #                   $peg_rank{$peg} = $counter;
1832    #                   $flag_set = 1;
1833    #               }
1834    #           }
1835    #           $counter++ if ($flag_set == 1);
1836    #       }
1837    #       else
1838    #       {
1839    #           foreach my $peg (@$good_set){
1840    #               $peg_rank{$peg} = "20";
1841    #           }
1842    #       }
1843    #    }
1844    
1845        foreach my $region (@$all_regions){
1846            my $sample_peg = @$region[0];
1847            my $region_genome = $fig->genome_of($sample_peg);
1848            my $region_gs = $fig->genus_species($region_genome);
1849            my $abbrev_name = $fig->abbrev($region_gs);
1850            my $line_config = { 'title' => $region_gs,
1851                                'short_title' => $abbrev_name,
1852                                'basepair_offset' => '0'
1853                                };
1854    
1855            my $offsetting = shift @start_array_region;
1856    
1857            my $second_line_config = { 'title' => "$region_gs",
1858                                       'short_title' => "",
1859                                       'basepair_offset' => '0'
1860                                       };
1861    
1862            my $line_data = [];
1863            my $second_line_data = [];
1864    
1865            # initialize variables to check for overlap in genes
1866            my ($prev_start, $prev_stop, $prev_fig, $second_line_flag);
1867            my $major_line_flag = 0;
1868            my $prev_second_flag = 0;
1869    
1870            foreach my $fid1 (@$region){
1871                $second_line_flag = 0;
1872                my $element_hash;
1873                my $links_list = [];
1874                my $descriptions = [];
1875    
1876                my $color = $peg_rank{$fid1};
1877    
1878                # get subsystem information
1879                my $function = $fig->function_of($fid1);
1880                my $url_link = "http://seed-viewer.theseed.org/index.cgi?action=ShowAnnotation&prot=".$fid1;
1881    
1882                my $link;
1883                $link = {"link_title" => $fid1,
1884                         "link" => $url_link};
1885                push(@$links_list,$link);
1886    
1887                my @subsystems = $fig->peg_to_subsystems($fid1);
1888                foreach my $subsystem (@subsystems){
1889                    my $link;
1890                    $link = {"link" => "http://seed-viewer.theseed.org/index.cgi?action=ShowSubsystem&subsystem_name=$subsystem",
1891                             "link_title" => $subsystem};
1892                    push(@$links_list,$link);
1893                }
1894    
1895                my $description_function;
1896                $description_function = {"title" => "function",
1897                                         "value" => $function};
1898                push(@$descriptions,$description_function);
1899    
1900                my $description_ss;
1901                my $ss_string = join (",", @subsystems);
1902                $description_ss = {"title" => "subsystems",
1903                                   "value" => $ss_string};
1904                push(@$descriptions,$description_ss);
1905    
1906    
1907                my $fid_location = $fig->feature_location($fid1);
1908                if($fid_location =~/(.*)_(\d+)_(\d+)$/){
1909                    my($start,$stop);
1910                    $start = $2 - $offsetting;
1911                    $stop = $3 - $offsetting;
1912    
1913                    if ( (($prev_start) && ($prev_stop) ) &&
1914                         ( ($start < $prev_start) || ($start < $prev_stop) ||
1915                           ($stop < $prev_start) || ($stop < $prev_stop) )){
1916                        if (($second_line_flag == 0) && ($prev_second_flag == 0)) {
1917                            $second_line_flag = 1;
1918                            $major_line_flag = 1;
1919                        }
1920                    }
1921                    $prev_start = $start;
1922                    $prev_stop = $stop;
1923                    $prev_fig = $fid1;
1924    
1925                    if ((defined($reverse_flag{$region_genome})) && ($reverse_flag{$region_genome} eq $all_genes{$fid1})){
1926                        $start = $gd_window_size - $start;
1927                        $stop = $gd_window_size - $stop;
1928                    }
1929    
1930                    $element_hash = {
1931                        "title" => $fid1,
1932                        "start" => $start,
1933                        "end" =>  $stop,
1934                        "type"=> 'arrow',
1935                        "color"=> $color,
1936                        "zlayer" => "2",
1937                        "links_list" => $links_list,
1938                        "description" => $descriptions
1939                    };
1940    
1941                    # if there is an overlap, put into second line
1942                    if ($second_line_flag == 1){ push(@$second_line_data,$element_hash); $prev_second_flag = 1;}
1943                    else{ push(@$line_data,$element_hash); $prev_second_flag = 0;}
1944    
1945                }
1946            }
1947            $gd->add_line($line_data, $line_config);
1948            $gd->add_line($second_line_data, $second_line_config) if ($major_line_flag == 1);
1949        }
1950        return $gd;
1951    }
1952    
1953    

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.26

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3