[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.8, Tue Jun 19 22:11:25 2007 UTC revision 1.40, Thu Sep 20 22:27:20 2007 UTC
# Line 1  Line 1 
1  package Observation;  package Observation;
2    
3    use lib '/vol/ontologies';
4    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 strict;  use FIG_Config;
11  use warnings;  #use strict;
12  use Table;  #use warnings;
13    use HTML;
14    
15  1;  1;
16    
# Line 22  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 65  Line 50 
50    
51  The public methods this package provides are listed below:  The public methods this package provides are listed below:
52    
53    
54    =head3 context()
55    
56    Returns close or diverse for purposes of displaying genomic context
57    
58    =cut
59    
60    sub context {
61      my ($self) = @_;
62    
63      return $self->{context};
64    }
65    
66    =head3 rows()
67    
68    each row in a displayed table
69    
70    =cut
71    
72    sub rows {
73      my ($self) = @_;
74    
75      return $self->{rows};
76    }
77    
78  =head3 acc()  =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.  A valid accession or remote ID (in the style of a db_xref) or a valid local ID (FID) in case this is supported.
# Line 73  Line 83 
83    
84  sub acc {  sub acc {
85    my ($self) = @_;    my ($self) = @_;
   
86    return $self->{acc};    return $self->{acc};
87  }  }
88    
89  =head3 description()  =head3 query()
90    
91  The description of the hit. Taken from the data or from the our Ontology database for some cases e.g. IPR or PFAM.  The query id
   
 B<Please note:>  
 Either remoteid or description is required.  
92    
93  =cut  =cut
94    
95  sub description {  sub query {
96    my ($self) = @_;    my ($self) = @_;
97        return $self->{query};
   return $self->{description};  
98  }  }
99    
100    
101  =head3 class()  =head3 class()
102    
103  The class of evidence (required). This is usually simply the name of the tool or the name of the SEED data structure.  The class of evidence (required). This is usually simply the name of the tool or the name of the SEED data structure.
# Line 101  Line 107 
107    
108  =over 9  =over 9
109    
110    =item IDENTICAL (seq)
111    
112  =item SIM (seq)  =item SIM (seq)
113    
114  =item BBH (seq)  =item BBH (seq)
# Line 115  Line 123 
123    
124  =item PFAM (dom)  =item PFAM (dom)
125    
126  =item SIGNALP (dom)  =item SIGNALP_CELLO_TMPRED (loc)
127    
128  =item  CELLO(loc)  =item PDB (seq)
129    
130  =item TMHMM (loc)  =item TMHMM (loc)
131    
# Line 156  Line 164 
164  sub type {  sub type {
165    my ($self) = @_;    my ($self) = @_;
166    
167    return $self->{acc};    return $self->{type};
168  }  }
169    
170  =head3 start()  =head3 start()
# Line 183  Line 191 
191    return $self->{stop};    return $self->{stop};
192  }  }
193    
194  =head3 evalue()  =head3 start()
195    
196  E-value or P-Value if present.  Start of hit in query sequence.
197    
198  =cut  =cut
199    
200  sub evalue {  sub qstart {
201    my ($self) = @_;    my ($self) = @_;
202    
203    return $self->{evalue};      return $self->{qstart};
204  }  }
205    
206  =head3 score()  =head3 qstop()
   
 Score if present.  
207    
208  B<Please note: >  End of the hit in query sequence.
 Either score or eval are required.  
209    
210  =cut  =cut
211    
212  sub score {  sub qstop {
213    my ($self) = @_;    my ($self) = @_;
214    return $self->{score};  
215        return $self->{qstop};
216  }  }
217    
218    =head3 hstart()
219    
220  =head3 display_method()  Start of hit in hit sequence.
221    
222  If available use the function specified here to display the "raw" observation.  =cut
 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".  
223    
224  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.  sub hstart {
225        my ($self) = @_;
226    
227  =cut      return $self->{hstart};
228    }
229    
230  sub display {  =head3 end()
231    
232    die "Abstract Method Called\n";  End of the hit in hit sequence.
233    
234  }  =cut
235    
236    sub hstop {
237        my ($self) = @_;
238    
239  =head3 rank()      return $self->{hstop};
240    }
241    
242  Returns an integer from 1 - 10 indicating the importance of this observations.  =head3 qlength()
243    
244  Currently always returns 1.  length of the query sequence in similarities
245    
246  =cut  =cut
247    
248  sub rank {  sub qlength {
249    my ($self) = @_;    my ($self) = @_;
250    
251  #  return $self->{rank};      return $self->{qlength};
   
   return 1;  
252  }  }
253    
254  =head3 supports_annotation()  =head3 hlength()
255    
256  Does a this observation support the annotation of its feature?  length of the hit sequence in similarities
257    
258  Returns  =cut
   
 =over 3  
259    
260  =item 10, if feature annotation is identical to $self->description  sub hlength {
261        my ($self) = @_;
262    
263  =item 1, Feature annotation is similar to $self->annotation; this is computed using FIG::SameFunc()      return $self->{hlength};
264    }
265    
266  =item undef  =head3 evalue()
267    
268  =back  E-value or P-Value if present.
269    
270  =cut  =cut
271    
272  sub supports_annotation {  sub evalue {
273    my ($self) = @_;    my ($self) = @_;
274    
275    # no code here so far    return $self->{evalue};
   
   return $self->{supports_annotation};  
276  }  }
277    
278  =head3 url()  =head3 score()
279    
280  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.  Score if present.
281    
282  =cut  =cut
283    
284  sub url {  sub score {
285    my ($self) = @_;    my ($self) = @_;
286      return $self->{score};
287    }
288    
289    =head3 display()
290    
291    will be different for each type
292    
293    =cut
294    
295    sub display {
296    
297    my $url = get_url($self->type, $self->acc);    die "Abstract Method Called\n";
298    
   return $url;  
299  }  }
300    
301  =head3 get_objects()  =head3 display_table()
302    
303  This is the B<REAL WORKHORSE> method of this Package.  will be different for each type
304    
305  It will probably have to:  =cut
306    
307    sub display_table {
308    
309      die "Abstract Table Method Called\n";
310    
 - 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;  
311   }   }
312    
313  It will invoke the required calls to the SEED API to retrieve the information required.  =head3 get_objects()
314    
315    This is the B<REAL WORKHORSE> method of this Package.
316    
317  =cut  =cut
318    
319  sub get_objects {  sub get_objects {
320      my ($self,$fid,$classes) = @_;      my ($self,$fid,$scope) = @_;
   
321    
322      my $objects = [];      my $objects = [];
323      my @matched_datasets=();      my @matched_datasets=();
324        my $fig = new FIG;
325    
326      # call function that fetches attribute based observations      # call function that fetches attribute based observations
327      # returns an array of arrays of hashes      # returns an array of arrays of hashes
328    
329      if(scalar(@$classes) < 1){      if($scope){
330          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);  
331      }      }
332      else{      else{
         #IPR,CDD,CELLO,PFAM,SIGNALP - attribute based  
333          my %domain_classes;          my %domain_classes;
334          foreach my $class (@$classes){          my @attributes = $fig->get_attributes($fid);
335              if($class =~/(IPR|CDD|PFAM)/){          $domain_classes{'CDD'} = 1;
336                  $domain_classes{$class} = 1;          get_identical_proteins($fid,\@matched_datasets);
337            get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets,\@attributes);
338              }          get_sims_observations($fid,\@matched_datasets);
339          }          get_functional_coupling($fid,\@matched_datasets);
340          get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets);          get_attribute_based_location_observations($fid,\@matched_datasets,\@attributes);
341            get_pdb_observations($fid,\@matched_datasets,\@attributes);
         #add CELLO and SignalP later  
342      }      }
343    
344      foreach my $dataset (@matched_datasets) {      foreach my $dataset (@matched_datasets) {
# Line 352  Line 346 
346          if($dataset->{'type'} eq "dom"){          if($dataset->{'type'} eq "dom"){
347              $object = Observation::Domain->new($dataset);              $object = Observation::Domain->new($dataset);
348          }          }
349            if($dataset->{'class'} eq "PCH"){
350                $object = Observation::FC->new($dataset);
351            }
352            if ($dataset->{'class'} eq "IDENTICAL"){
353                $object = Observation::Identical->new($dataset);
354            }
355            if ($dataset->{'class'} eq "SIGNALP_CELLO_TMPRED"){
356                $object = Observation::Location->new($dataset);
357            }
358            if ($dataset->{'class'} eq "SIM"){
359                $object = Observation::Sims->new($dataset);
360            }
361            if ($dataset->{'class'} eq "CLUSTER"){
362                $object = Observation::Cluster->new($dataset);
363            }
364            if ($dataset->{'class'} eq "PDB"){
365                $object = Observation::PDB->new($dataset);
366            }
367    
368          push (@$objects, $object);          push (@$objects, $object);
369      }      }
370    
# Line 359  Line 372 
372    
373  }  }
374    
375  =head1 Internal Methods  =head3 display_housekeeping
376    This method returns the housekeeping data for a given peg in a table format
377    
378  These methods are not meant to be used outside of this package.  =cut
379    sub display_housekeeping {
380        my ($self,$fid) = @_;
381        my $fig = new FIG;
382        my $content;
383    
384  B<Please do not use them outside of this package!>      my $org_name = $fig->org_of($fid);
385        my $org_id   = $fig->orgid_of_orgname($org_name);
386        my $loc      = $fig->feature_location($fid);
387        my($contig, $beg, $end) = $fig->boundaries_of($loc);
388        my $strand   = ($beg <= $end)? '+' : '-';
389        my @subsystems = $fig->subsystems_for_peg($fid);
390        my $function = $fig->function_of($fid);
391        my @aliases  = $fig->feature_aliases($fid);
392        my $taxonomy = $fig->taxonomy_of($org_id);
393        my @ecs = ($function =~ /\(EC\s(\d+\.[-\d+]+\.[-\d+]+\.[-\d+]+)\)/g);
394    
395  =cut      $content .= qq(<b>General Protein Data</b><br><br><br><table border="0">);
396        $content .= qq(<tr width=15%><td >FIG ID</td><td>$fid</td></tr>\n);
397        $content .= qq(<tr width=15%><td >Organism Name</td><td>$org_name,&nbsp;&nbsp;$org_id</td></tr>\n);
398        $content .= qq(<tr><td width=15%>Taxonomy</td><td>$taxonomy</td></tr>\n);
399        $content .= qq(<tr width=15%><td>FIG Organism ID</td><td>$org_id</td></tr>\n);
400        $content .= qq(<tr width=15%><td>Gene Location</td><td>Contig $contig [$beg,$end], Strand $strand</td></tr>\n);;
401        $content .= qq(<tr width=15%><td>Function</td><td>$function</td></tr>\n);
402        if ( @ecs ) {
403            $content .= qq(<tr><td>EC:</td><td>);
404            foreach my $ec ( @ecs ) {
405                my $ec_name = $fig->ec_name($ec);
406                $content .= join(" -- ", $ec, $ec_name) . "<br>\n";
407            }
408            $content .= qq(</td></tr>\n);
409        }
410    
411        if ( @subsystems ) {
412            $content .= qq(<tr><td>Subsystems</td><td>);
413            foreach my $subsystem ( @subsystems ) {
414                $content .= join(" -- ", @$subsystem) . "<br>\n";
415            }
416        }
417    
418  =head3 get_url (internal)      my %groups;
419        if ( @aliases ) {
420            # get the db for each alias
421            foreach my $alias (@aliases){
422                $groups{$alias} = &get_database($alias);
423            }
424    
425  get_url() return a valid URL or undef for any observation.          # group ids by aliases
426            my %db_aliases;
427            foreach my $key (sort {$groups{$a} cmp $groups{$b}} keys %groups){
428                push (@{$db_aliases{$groups{$key}}}, $key);
429            }
430    
 URLs are constructed by looking at the Accession acc()  and  name()  
431    
432  Info from both attributes is combined with a table of base URLs stored in this function.          $content .= qq(<tr><td>Aliases</td><td><table border="0">);
433            foreach my $key (sort keys %db_aliases){
434                $content .= qq(<tr><td>$key:</td><td>) . join(", ", @{$db_aliases{$key}}) . qq(</td></tr\n);
435            }
436            $content .= qq(</td></tr></table>\n);
437        }
438    
439  =cut      $content .= qq(</table><p>\n);
440    
441  sub get_url {      return ($content);
442    }
443    
444   my ($self) = @_;  =head3 get_sims_summary
445   my $url='';  This method uses as input the similarities of a peg and creates a tree view of their taxonomy
446    
447  # a hash with a URL for each observation; identified by name()  =cut
 #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="  
 #};  
448    
449  # if (defined $URL{$self->name}) {  sub get_sims_summary {
450  #     $url = $URL{$self->name}.$self->acc;      my ($observation, $fid, $taxes) = @_;
451  #     return $url;      my $fig = new FIG;
452  # }      my %families;
453  # else      my @sims= $fig->nsims($fid,20000,10,"fig");
454       return undef;  
455        foreach my $sim (@sims){
456            next if ($sim->[1] !~ /fig\|/);
457            my $genome = $fig->genome_of($sim->[1]);
458            my ($genome1) = ($genome) =~ /(.*)\./;
459            my $taxonomy = $taxes->{$genome1};
460            #my $taxonomy = $fig->taxonomy_of($fig->genome_of($sim->[1])); # use this if the taxonomies have been updated
461            my $parent_tax = "Root";
462            my @currLineage = ($parent_tax);
463            foreach my $tax (split(/\; /, $taxonomy)){
464                push (@{$families{children}{$parent_tax}}, $tax);
465                push (@currLineage, $tax);
466                $families{parent}{$tax} = $parent_tax;
467                $families{lineage}{$tax} = join(";", @currLineage);
468                if (defined ($families{evalue}{$tax})){
469                    if ($sim->[10] < $families{evalue}{$tax}){
470                        $families{evalue}{$tax} = $sim->[10];
471                        $families{color}{$tax} = &get_taxcolor($sim->[10]);
472                    }
473                }
474                else{
475                    $families{evalue}{$tax} = $sim->[10];
476                    $families{color}{$tax} = &get_taxcolor($sim->[10]);
477  }  }
478    
479  =head3 get_display_method (internal)              $parent_tax = $tax;
480            }
481        }
482    
483  get_display_method() return a valid URL or undef for any observation.      foreach my $key (keys %{$families{children}}){
484            $families{count}{$key} = @{$families{children}{$key}};
485    
486  URLs are constructed by looking at the Accession acc()  and  name()          my %saw;
487  and Info from both attributes is combined with a table of base URLs stored in this function.          my @out = grep(!$saw{$_}++, @{$families{children}{$key}});
488            $families{children}{$key} = \@out;
489        }
490        return (\%families);
491    }
492    
493  =cut  =head1 Internal Methods
494    
495  sub get_display_method {  These methods are not meant to be used outside of this package.
496    
497   my ($self) = @_;  B<Please do not use them outside of this package!>
498    
499  # a hash with a URL for each observation; identified by name()  =cut
 #my $URL             => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\  
 #                        'bbh'=> "http://www.theseed.org/featalign.cgi?id1="  
 # };  
500    
501  #if (defined $URL{$self->name}) {  sub get_taxcolor{
502  #     $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc;      my ($evalue) = @_;
503  #     return $url;      my $color;
504  # }      if ($evalue <= 1e-170){        $color = "#FF2000";    }
505  # else      elsif (($evalue <= 1e-120) && ($evalue > 1e-170)){        $color = "#FF3300";    }
506       return undef;      elsif (($evalue <= 1e-90) && ($evalue > 1e-120)){        $color = "#FF6600";    }
507        elsif (($evalue <= 1e-70) && ($evalue > 1e-90)){        $color = "#FF9900";    }
508        elsif (($evalue <= 1e-40) && ($evalue > 1e-70)){        $color = "#FFCC00";    }
509        elsif (($evalue <= 1e-20) && ($evalue > 1e-40)){        $color = "#FFFF00";    }
510        elsif (($evalue <= 1e-5) && ($evalue > 1e-20)){        $color = "#CCFF00";    }
511        elsif (($evalue <= 1) && ($evalue > 1e-5)){        $color = "#66FF00";    }
512        elsif (($evalue <= 10) && ($evalue > 1)){        $color = "#00FF00";    }
513        else{        $color = "#6666FF";    }
514        return ($color);
515  }  }
516    
517    
518  sub get_attribute_based_domain_observations{  sub get_attribute_based_domain_observations{
519    
520      # 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)
521      my ($fid,$domain_classes,$datasets_ref) = (@_);      my ($fid,$domain_classes,$datasets_ref,$attributes_ref) = (@_);
522    
523      my $fig = new FIG;      my $fig = new FIG;
524    
525      foreach my $attr_ref ($fig->get_attributes($fid)) {      foreach my $attr_ref (@$attributes_ref) {
526    #    foreach my $attr_ref ($fig->get_attributes($fid)) {
527          my $key = @$attr_ref[1];          my $key = @$attr_ref[1];
528          my @parts = split("::",$key);          my @parts = split("::",$key);
529          my $class = $parts[0];          my $class = $parts[0];
# Line 461  Line 549 
549                                 'type' => "dom" ,                                 'type' => "dom" ,
550                                 'evalue' => $evalue,                                 'evalue' => $evalue,
551                                 'start' => $from,                                 'start' => $from,
552                                 'stop' => $to                                 'stop' => $to,
553                                   'fig_id' => $fid,
554                                   'score' => $raw_evalue
555                                 };                                 };
556    
557                  push (@{$datasets_ref} ,$dataset);                  push (@{$datasets_ref} ,$dataset);
# Line 470  Line 560 
560      }      }
561  }  }
562    
563  =head3 get_attribute_based_evidence (internal)  sub get_attribute_based_location_observations{
   
 This method retrieves evidence from the attribute server  
564    
565  =cut      my ($fid,$datasets_ref, $attributes_ref) = (@_);
566        my $fig = new FIG;
567    
568  sub get_attribute_based_observations{      my $location_attributes = ['SignalP','CELLO','TMPRED','Phobius'];
569    
570      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)      my $dataset = {'type' => "loc",
571      my ($fid,$datasets_ref) = (@_);                     'class' => 'SIGNALP_CELLO_TMPRED',
572                       'fig_id' => $fid
573                       };
574    
575      my $_myfig = new FIG;      foreach my $attr_ref (@$attributes_ref){
576    #    foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) {
577            my $key = @$attr_ref[1];
578            next if (($key !~ /SignalP/) && ($key !~ /CELLO/) && ($key !~ /TMPRED/)  && ($key !~/Phobius/) );
579            my @parts = split("::",$key);
580            my $sub_class = $parts[0];
581            my $sub_key = $parts[1];
582            my $value = @$attr_ref[2];
583            if($sub_class eq "SignalP"){
584                if($sub_key eq "cleavage_site"){
585                    my @value_parts = split(";",$value);
586                    $dataset->{'cleavage_prob'} = $value_parts[0];
587                    $dataset->{'cleavage_loc'} = $value_parts[1];
588    #               print STDERR "LOC: $value_parts[1]";
589                }
590                elsif($sub_key eq "signal_peptide"){
591                    $dataset->{'signal_peptide_score'} = $value;
592                }
593            }
594    
595      foreach my $attr_ref ($_myfig->get_attributes($fid)) {          elsif($sub_class eq "CELLO"){
596                $dataset->{'cello_location'} = $sub_key;
597                $dataset->{'cello_score'} = $value;
598            }
599    
600          # convert the ref into a string for easier handling          elsif($sub_class eq "Phobius"){
601          my ($string) = "@$attr_ref";              if($sub_key eq "transmembrane"){
602                    $dataset->{'phobius_tm_locations'} = $value;
603                }
604                elsif($sub_key eq "signal"){
605                    $dataset->{'phobius_signal_location'} = $value;
606                }
607            }
608    
609  #       print "S:$string\n";          elsif($sub_class eq "TMPRED"){
610          my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/);              my @value_parts = split(/\;/,$value);
611                $dataset->{'tmpred_score'} = $value_parts[0];
612                $dataset->{'tmpred_locations'} = $value_parts[1];
613            }
614        }
615    
616          # THIS SHOULD BE DONE ANOTHER WAY FM->TD      push (@{$datasets_ref} ,$dataset);
         # 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  
         #  
617    
618          if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) {  }
619    
620              # some keys are composite CDD::1233244 or PFAM:PF1233  =head3 get_pdb_observations() (internal)
621    
622              if ( $key =~ /::/ ) {  This methods sets the type and class for pdb observations
                 my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/);  
                 $val=$restkey.";".$val;  
                 $key=$firstkey;  
             }  
623    
624              my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ );  =cut
625    
626              my $evalue= 255;  sub get_pdb_observations{
627              if (defined $raw_evalue) { # some of the tool do not give us an evalue      my ($fid,$datasets_ref, $attributes_ref) = (@_);
628    
629                  my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/);      my $fig = new FIG;
                 my ($new_k, $new_exp);  
630    
631                  #      foreach my $attr_ref (@$attributes_ref){
632                  #  THIS DOES NOT WORK PROPERLY      #foreach my $attr_ref ($fig->get_attributes($fid,'PDB')) {
                 #  
                 if($raw_evalue =~/(\d+).(\d+)/){  
633    
634  #                   $new_exp = (1000+$expo);          my $key = @$attr_ref[1];
635          #           $new_k = $k / 100;          next if ( ($key !~ /PDB/));
636            my($key1,$key2) =split("::",$key);
637            my $value = @$attr_ref[2];
638            my ($evalue,$location) = split(";",$value);
639    
640                  }          if($evalue =~/(\d+)\.(\d+)/){
641                  $evalue = "0.01"#new_k."e-".$new_exp;              my $part2 = 1000 - $1;
642                my $part1 = $2/100;
643                $evalue = $part1."e-".$part2;
644              }              }
645    
646              # unroll it all into an array of hashes          my($start,$stop) =split("-",$location);
647              # this needs to be done differently for different types of observations  
648              my $dataset = [ { name => 'class', value => $key },          my $url = @$attr_ref[3];
649                              { name => 'acc' , value => $acc},          my $dataset = {'class' => 'PDB',
650                              { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD                         'type' => 'seq' ,
651                              { name => 'evalue', value => $evalue },                         'acc' => $key2,
652                              { name => 'start', value => $from},                         'evalue' => $evalue,
653                              { name => 'stop' , value => $to}                         'start' => $start,
654                              ];                         'stop' => $stop,
655                           'fig_id' => $fid
656                           };
657    
658              push (@{$datasets_ref} ,$dataset);              push (@{$datasets_ref} ,$dataset);
659          }          }
660      }      }
661    
662    =head3 get_cluster_observations() (internal)
663    
664    This methods sets the type and class for cluster observations
665    
666    =cut
667    
668    sub get_cluster_observations{
669        my ($fid,$datasets_ref,$scope) = (@_);
670    
671        my $dataset = {'class' => 'CLUSTER',
672                       'type' => 'fc',
673                       'context' => $scope,
674                       'fig_id' => $fid
675                       };
676        push (@{$datasets_ref} ,$dataset);
677  }  }
678    
679    
680  =head3 get_sims_observations() (internal)  =head3 get_sims_observations() (internal)
681    
682  This methods retrieves sims fills the internal data structures.  This methods retrieves sims fills the internal data structures.
# Line 552  Line 687 
687    
688      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
689      my $fig = new FIG;      my $fig = new FIG;
690      my @sims= $fig->nsims($fid,100,1e-20,"fig");      my @sims= $fig->nsims($fid,500,10,"fig");
691      my ($dataset);      my ($dataset);
692    
693        my %id_list;
694        foreach my $sim (@sims){
695            my $hit = $sim->[1];
696    
697            next if ($hit !~ /^fig\|/);
698            my @aliases = $fig->feature_aliases($hit);
699            foreach my $alias (@aliases){
700                $id_list{$alias} = 1;
701            }
702        }
703    
704        my %already;
705        my (@new_sims, @uniprot);
706      foreach my $sim (@sims){      foreach my $sim (@sims){
707          my $hit = $sim->[1];          my $hit = $sim->[1];
708            my ($id) = ($hit) =~ /\|(.*)/;
709            next if (defined($already{$id}));
710            next if (defined($id_list{$hit}));
711            push (@new_sims, $sim);
712            $already{$id} = 1;
713        }
714    
715        foreach my $sim (@new_sims){
716            my $hit = $sim->[1];
717            my $percent = $sim->[2];
718          my $evalue = $sim->[10];          my $evalue = $sim->[10];
719          my $from = $sim->[8];          my $qfrom = $sim->[6];
720          my $to = $sim->[9];          my $qto = $sim->[7];
721          $dataset = [ { name => 'class', value => "SIM" },          my $hfrom = $sim->[8];
722                          { name => 'acc' , value => $hit},          my $hto = $sim->[9];
723                          { name => 'type', value => "seq"} ,          my $qlength = $sim->[12];
724                          { name => 'evalue', value => $evalue },          my $hlength = $sim->[13];
725                          { name => 'start', value => $from},          my $db = get_database($hit);
726                          { name => 'stop' , value => $to}          my $func = $fig->function_of($hit);
727                          ];          my $organism = $fig->org_of($hit);
728    
729            $dataset = {'class' => 'SIM',
730                        'query' => $sim->[0],
731                        'acc' => $hit,
732                        'identity' => $percent,
733                        'type' => 'seq',
734                        'evalue' => $evalue,
735                        'qstart' => $qfrom,
736                        'qstop' => $qto,
737                        'hstart' => $hfrom,
738                        'hstop' => $hto,
739                        'database' => $db,
740                        'organism' => $organism,
741                        'function' => $func,
742                        'qlength' => $qlength,
743                        'hlength' => $hlength,
744                        'fig_id' => $fid
745                        };
746    
747      push (@{$datasets_ref} ,$dataset);      push (@{$datasets_ref} ,$dataset);
748      }      }
749  }  }
750    
751    =head3 get_database (internal)
752    This method gets the database association from the sequence id
753    
754    =cut
755    
756    sub get_database{
757        my ($id) = (@_);
758    
759        my ($db);
760        if ($id =~ /^fig\|/)              { $db = "FIG" }
761        elsif ($id =~ /^gi\|/)            { $db = "NCBI" }
762        elsif ($id =~ /^^[NXYZA]P_/)      { $db = "RefSeq" }
763        elsif ($id =~ /^sp\|/)            { $db = "SwissProt" }
764        elsif ($id =~ /^uni\|/)           { $db = "UniProt" }
765        elsif ($id =~ /^tigr\|/)          { $db = "TIGR" }
766        elsif ($id =~ /^pir\|/)           { $db = "PIR" }
767        elsif (($id =~ /^kegg\|/) || ($id =~ /Spy/))    { $db = "KEGG" }
768        elsif ($id =~ /^tr\|/)                          { $db = "TrEMBL" }
769        elsif ($id =~ /^eric\|/)          { $db = "ASAP" }
770        elsif ($id =~ /^img\|/)           { $db = "JGI" }
771    
772        return ($db);
773    
774    }
775    
776    
777  =head3 get_identical_proteins() (internal)  =head3 get_identical_proteins() (internal)
778    
779  This methods retrieves sims fills the internal data structures.  This methods retrieves sims fills the internal data structures.
# Line 580  Line 784 
784    
785      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
786      my $fig = new FIG;      my $fig = new FIG;
787      my @funcs = ();      my $funcs_ref;
788    
789    #    my %id_list;
790      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);
791    #    my @aliases = $fig->feature_aliases($fid);
792    #    foreach my $alias (@aliases){
793    #       $id_list{$alias} = 1;
794    #    }
795    
796      foreach my $id (@maps_to) {      foreach my $id (@maps_to) {
797          my ($tmp, $who);          my ($tmp, $who);
798          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {
799              if ($id =~ /^fig\|/)           { $who = "FIG" }  #        if (($id ne $fid) && ($tmp = $fig->function_of($id)) && (! defined ($id_list{$id}))) {
800              elsif ($id =~ /^gi\|/)            { $who = "NCBI" }              $who = &get_database($id);
801              elsif ($id =~ /^^[NXYZA]P_/)      { $who = "RefSeq" }              push(@$funcs_ref, [$id,$who,$tmp]);
             elsif ($id =~ /^sp\|/)            { $who = "SwissProt" }  
             elsif ($id =~ /^uni\|/)           { $who = "UniProt" }  
             elsif ($id =~ /^tigr\|/)          { $who = "TIGR" }  
             elsif ($id =~ /^pir\|/)           { $who = "PIR" }  
             elsif ($id =~ /^kegg\|/)          { $who = "KEGG" }  
             elsif ($id =~ /^tr\|/)            { $who = "TrEMBL" }  
             elsif ($id =~ /^eric\|/)          { $who = "ASAP" }  
   
             push(@funcs, [$id,$who,$tmp]);  
802          }          }
803      }      }
804    
805      my ($dataset);      my ($dataset);
806      foreach my $row (@funcs){      my $dataset = {'class' => 'IDENTICAL',
807          my $id = $row->[0];                     'type' => 'seq',
808          my $organism = $fig->org_of($fid);                     'fig_id' => $fid,
809          my $who = $row->[1];                     'rows' => $funcs_ref
810          my $assignment = $row->[2];                     };
811          $dataset = [ { name => 'class', value => "IDENTICAL" },  
                      { name => 'id' , value => $id},  
                      { name => 'organism', value => "$organism"} ,  
                      { name => 'database', value => $who },  
                      { name => 'description' , value => $assignment}  
                      ];  
812          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
813      }  
814    
815  }  }
816    
# Line 646  Line 841 
841                    } @fc_data;                    } @fc_data;
842    
843      my ($dataset);      my ($dataset);
844      foreach my $row (@rows){      my $dataset = {'class' => 'PCH',
845          my $id = $row->[1];                     'type' => 'fc',
846          my $score = $row->[0];                     'fig_id' => $fid,
847          my $description = $row->[2];                     'rows' => \@rows
848          $dataset = [ { name => 'class', value => "FC" },                     };
849                       { name => 'score' , value => $score},  
                      { name => 'id', value => "$id"} ,  
                      { name => 'description' , value => $description}  
                      ];  
850          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
851      }  
852  }  }
853    
854  =head3 get_sims_and_bbhs() (internal)  =head3 new (internal)
855    
856  This methods retrieves sims and also BBHs and fills the internal data structures.  Instantiate a new object.
857    
858  =cut  =cut
859    
860  #     sub get_sims_and_bbhs{  sub new {
861      my ($class,$dataset) = @_;
 #       # 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";  
 #       }  
862    
863  #     }    my $self = { class => $dataset->{'class'},
864                   type => $dataset->{'type'},
865                   fig_id => $dataset->{'fig_id'},
866                   score => $dataset->{'score'},
867               };
868    
869      bless($self,$class);
870    
871      return $self;
872    }
873    
874  =head3 new (internal)  =head3 identity (internal)
875    
876  Instantiate a new object.  Returns the % identity of the similar sequence
877    
878  =cut  =cut
879    
880  sub new {  sub identity {
881    my ($class,$dataset) = @_;      my ($self) = @_;
   
882    
883    #$self = { acc => '',      return $self->{identity};
884  #           description => '',  }
 #           class => '',  
 #           type => '',  
 #           start => '',  
 #           stop => '',  
 #           evalue => '',  
 #           score => '',  
 #           display_method => '',  
 #           feature_id => '',  
 #           rank => '',  
 #           supports_annotation => '',  
 #           id => '',  
 #            organism => '',  
 #            who => ''  
 #         };  
885    
886    my $self = { class => $dataset->{'class'},  =head3 fig_id (internal)
                type => $dataset->{'type'}  
             };  
887    
888    bless($self,$class);  =cut
889    
890    return $self;  sub fig_id {
891      my ($self) = @_;
892      return $self->{fig_id};
893  }  }
894    
895  =head3 feature_id (internal)  =head3 feature_id (internal)
# Line 775  Line 927 
927      return $self->{organism};      return $self->{organism};
928  }  }
929    
930  =head3 database (internal)  =head3 function (internal)
931    
932  Returns the database of the identical sequence  Returns the function of the identical sequence
933    
934  =cut  =cut
935    
936  sub database {  sub function {
937      my ($self) = @_;      my ($self) = @_;
938    
939      return $self->{database};      return $self->{function};
940  }  }
941    
942  #package Observation::Identical;  =head3 database (internal)
 #1;  
 #  
 #our @ISA = qw(Observation);  # inherits all the methods from Observation  
943    
944  =head3 display_identical()  Returns the database of the identical sequence
945    
946    =cut
947    
948    sub database {
949        my ($self) = @_;
950    
951        return $self->{database};
952    }
953    
954    sub score {
955      my ($self) = @_;
956    
957      return $self->{score};
958    }
959    
960    ############################################################
961    ############################################################
962    package Observation::PDB;
963    
964    use base qw(Observation);
965    
966    sub new {
967    
968        my ($class,$dataset) = @_;
969        my $self = $class->SUPER::new($dataset);
970        $self->{acc} = $dataset->{'acc'};
971        $self->{evalue} = $dataset->{'evalue'};
972        $self->{start} = $dataset->{'start'};
973        $self->{stop} = $dataset->{'stop'};
974        bless($self,$class);
975        return $self;
976    }
977    
978    =head3 display()
979    
980    displays data stored in best_PDB attribute and in Ontology server for given PDB id
981    
982    =cut
983    
984    sub display{
985        my ($self,$gd) = @_;
986    
987        my $fid = $self->fig_id;
988        my $dbmaster = DBMaster->new(-database =>'Ontology');
989    
990        my $acc = $self->acc;
991    
992        my ($pdb_description,$pdb_source,$pdb_ligand);
993        my $pdb_objs = $dbmaster->pdb->get_objects( { 'id' => $acc } );
994        if(!scalar(@$pdb_objs)){
995            $pdb_description = "not available";
996            $pdb_source = "not available";
997            $pdb_ligand = "not available";
998        }
999        else{
1000            my $pdb_obj = $pdb_objs->[0];
1001            $pdb_description = $pdb_obj->description;
1002            $pdb_source = $pdb_obj->source;
1003            $pdb_ligand = $pdb_obj->ligand;
1004        }
1005    
1006        my $lines = [];
1007        my $line_data = [];
1008        my $line_config = { 'title' => "PDB hit for $fid",
1009                            'short_title' => "best PDB",
1010                            'basepair_offset' => '1' };
1011    
1012        my $fig = new FIG;
1013        my $seq = $fig->get_translation($fid);
1014        my $fid_stop = length($seq);
1015    
1016        my $fid_element_hash = {
1017            "title" => $fid,
1018            "start" => '1',
1019            "end" =>  $fid_stop,
1020            "color"=> '1',
1021            "zlayer" => '1'
1022            };
1023    
1024        push(@$line_data,$fid_element_hash);
1025    
1026        my $links_list = [];
1027        my $descriptions = [];
1028    
1029        my $name;
1030        $name = {"title" => 'id',
1031                 "value" => $acc};
1032        push(@$descriptions,$name);
1033    
1034        my $description;
1035        $description = {"title" => 'pdb description',
1036                        "value" => $pdb_description};
1037        push(@$descriptions,$description);
1038    
1039        my $score;
1040        $score = {"title" => "score",
1041                  "value" => $self->evalue};
1042        push(@$descriptions,$score);
1043    
1044        my $start_stop;
1045        my $start_stop_value = $self->start."_".$self->stop;
1046        $start_stop = {"title" => "start-stop",
1047                       "value" => $start_stop_value};
1048        push(@$descriptions,$start_stop);
1049    
1050        my $source;
1051        $source = {"title" => "source",
1052                  "value" => $pdb_source};
1053        push(@$descriptions,$source);
1054    
1055        my $ligand;
1056        $ligand = {"title" => "pdb ligand",
1057                   "value" => $pdb_ligand};
1058        push(@$descriptions,$ligand);
1059    
1060        my $link;
1061        my $link_url ="http://www.rcsb.org/pdb/explore/explore.do?structureId=".$acc;
1062    
1063        $link = {"link_title" => $acc,
1064                 "link" => $link_url};
1065        push(@$links_list,$link);
1066    
1067        my $pdb_element_hash = {
1068            "title" => "PDB homology",
1069            "start" => $self->start,
1070            "end" =>  $self->stop,
1071            "color"=> '6',
1072            "zlayer" => '3',
1073            "links_list" => $links_list,
1074            "description" => $descriptions};
1075    
1076        push(@$line_data,$pdb_element_hash);
1077        $gd->add_line($line_data, $line_config);
1078    
1079        return $gd;
1080    }
1081    
1082    1;
1083    
1084    ############################################################
1085    ############################################################
1086    package Observation::Identical;
1087    
1088    use base qw(Observation);
1089    
1090    sub new {
1091    
1092        my ($class,$dataset) = @_;
1093        my $self = $class->SUPER::new($dataset);
1094        $self->{rows} = $dataset->{'rows'};
1095    
1096        bless($self,$class);
1097        return $self;
1098    }
1099    
1100    =head3 display_table()
1101    
1102  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
1103  This code will display a table for the identical protein  This code will display a table for the identical protein
1104    
1105    
1106  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.  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
1107    dence.
1108    
1109  =cut  =cut
1110    
 sub display_identical {  
     my ($self, $fid, $cgi) = @_;  
1111    
1112      my $content;  sub display_table{
1113      my $array=Observation->get_objects($fid);      my ($self) = @_;
1114    
1115        my $fig = new FIG;
1116        my $fid = $self->fig_id;
1117        my $rows = $self->rows;
1118        my $cgi = new CGI;
1119      my $all_domains = [];      my $all_domains = [];
1120      my $count_identical = 0;      my $count_identical = 0;
1121      foreach my $thing (@$array) {      my $content;
1122          next if ($thing->class ne "IDENTICAL");      foreach my $row (@$rows) {
1123            my $id = $row->[0];
1124            my $who = $row->[1];
1125            my $assignment = $row->[2];
1126            my $organism = $fig->org_of($id);
1127          my $single_domain = [];          my $single_domain = [];
1128          push(@$single_domain,$thing->class);          push(@$single_domain,$who);
         my $id = $thing->id;  
         $count_identical++;  
1129          push(@$single_domain,&HTML::set_prot_links($cgi,$id));          push(@$single_domain,&HTML::set_prot_links($cgi,$id));
1130          push(@$single_domain,$thing->organism);          push(@$single_domain,$organism);
1131          push(@$single_domain,$thing->database);          push(@$single_domain,$assignment);
         push(@$single_domain,$thing->description);  
1132          push(@$all_domains,$single_domain);          push(@$all_domains,$single_domain);
1133            $count_identical++;
1134      }      }
1135    
1136      if ($count_identical >0){      if ($count_identical >0){
1137          my $table_component = $self->application->component('DomainTable');          $content = $all_domains;
   
         $table_component->columns ([ { 'name' => 'Name', 'filter' => 1 },  
                                      { 'name' => 'ID' },  
                                      { 'name' => 'Organism' },  
                                      { 'name' => 'Database' },  
                                      { 'name' => 'Assignment' }  
                                      ]);  
         $table_component->data($all_domains);  
         $table_component->show_top_browse(1);  
         $table_component->show_bottom_browse(1);  
         $table_component->items_per_page(50);  
         $table_component->show_select_items_per_page(1);  
         $content .= $table_component->output();  
1138      }      }
1139      else{      else{
1140          $content = "<p>This PEG does not have any essentially identical proteins</p>";          $content = "<p>This PEG does not have any essentially identical proteins</p>";
# Line 845  Line 1142 
1142      return ($content);      return ($content);
1143  }  }
1144    
1145    1;
1146    
1147    #########################################
1148    #########################################
1149    package Observation::FC;
1150    1;
1151    
1152    use base qw(Observation);
1153    
1154    sub new {
1155    
1156        my ($class,$dataset) = @_;
1157        my $self = $class->SUPER::new($dataset);
1158        $self->{rows} = $dataset->{'rows'};
1159    
1160        bless($self,$class);
1161        return $self;
1162    }
1163    
1164    =head3 display_table()
1165    
1166    If available use the function specified here to display the "raw" observation.
1167    This code will display a table for the identical protein
1168    
1169    
1170    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
1171    dence.
1172    
1173    =cut
1174    
1175    sub display_table {
1176    
1177        my ($self,$dataset) = @_;
1178        my $fid = $self->fig_id;
1179        my $rows = $self->rows;
1180        my $cgi = new CGI;
1181        my $functional_data = [];
1182        my $count = 0;
1183        my $content;
1184    
1185        foreach my $row (@$rows) {
1186            my $single_domain = [];
1187            $count++;
1188    
1189            # construct the score link
1190            my $score = $row->[0];
1191            my $toid = $row->[1];
1192            my $link = $cgi->url(-relative => 1) . "?user=master&request=show_coupling_evidence&prot=$fid&to=$toid&SPROUT=";
1193            my $sc_link = "<a href=$link>$score</a>";
1194    
1195            push(@$single_domain,$sc_link);
1196            push(@$single_domain,$row->[1]);
1197            push(@$single_domain,$row->[2]);
1198            push(@$functional_data,$single_domain);
1199        }
1200    
1201        if ($count >0){
1202            $content = $functional_data;
1203        }
1204        else
1205        {
1206            $content = "<p>This PEG does not have any functional coupling</p>";
1207        }
1208        return ($content);
1209    }
1210    
1211    
1212    #########################################
1213    #########################################
1214  package Observation::Domain;  package Observation::Domain;
1215    
1216  use base qw(Observation);  use base qw(Observation);
# Line 865  Line 1231 
1231  sub display {  sub display {
1232      my ($thing,$gd) = @_;      my ($thing,$gd) = @_;
1233      my $lines = [];      my $lines = [];
1234      my $line_config = { 'title' => $thing->acc,  #    my $line_config = { 'title' => $thing->acc,
1235                          'short_title' => $thing->type,  #                       'short_title' => $thing->type,
1236                          'basepair_offset' => '1' };  #                       'basepair_offset' => '1' };
1237      my $color = "4";      my $color = "4";
1238    
1239      my $line_data = [];      my $line_data = [];
1240      my $links_list = [];      my $links_list = [];
1241      my $descriptions = [];      my $descriptions = [];
1242    
1243      my $description_function;      my $db_and_id = $thing->acc;
1244      $description_function = {"title" => $thing->class,      my ($db,$id) = split("::",$db_and_id);
                              "value" => $thing->acc};  
1245    
1246      push(@$descriptions,$description_function);      my $dbmaster = DBMaster->new(-database =>'Ontology');
1247    
1248        my ($name_title,$name_value,$description_title,$description_value);
1249        if($db eq "CDD"){
1250            my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1251            if(!scalar(@$cdd_objs)){
1252                $name_title = "name";
1253                $name_value = "not available";
1254                $description_title = "description";
1255                $description_value = "not available";
1256            }
1257            else{
1258                my $cdd_obj = $cdd_objs->[0];
1259                $name_title = "name";
1260                $name_value = $cdd_obj->term;
1261                $description_title = "description";
1262                $description_value = $cdd_obj->description;
1263            }
1264        }
1265    
1266        my $line_config = { 'title' => $thing->acc,
1267                            'short_title' => $name_value,
1268                            'basepair_offset' => '1' };
1269    
1270        my $name;
1271        $name = {"title" => $name_title,
1272                 "value" => $name_value};
1273        push(@$descriptions,$name);
1274    
1275        my $description;
1276        $description = {"title" => $description_title,
1277                                 "value" => $description_value};
1278        push(@$descriptions,$description);
1279    
1280      my $score;      my $score;
1281      $score = {"title" => "score",      $score = {"title" => "score",
# Line 886  Line 1283 
1283      push(@$descriptions,$score);      push(@$descriptions,$score);
1284    
1285      my $link_id;      my $link_id;
1286      if ($thing->acc =~/CDD::(\d+)/){      if ($thing->acc =~/\w+::(\d+)/){
1287          $link_id = $1;          $link_id = $1;
1288      }      }
1289    
1290      my $link;      my $link;
1291        my $link_url;
1292        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"}
1293        elsif($thing->class eq "PFAM"){$link_url = "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?$link_id"}
1294        else{$link_url = "NO_URL"}
1295    
1296      $link = {"link_title" => $thing->acc,      $link = {"link_title" => $thing->acc,
1297               "link" => "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"};               "link" => $link_url};
1298      push(@$links_list,$link);      push(@$links_list,$link);
1299    
1300      my $element_hash = {      my $element_hash = {
# Line 911  Line 1313 
1313    
1314  }  }
1315    
1316    sub display_table {
1317        my ($self,$dataset) = @_;
1318        my $cgi = new CGI;
1319        my $data = [];
1320        my $count = 0;
1321        my $content;
1322    
1323        foreach my $thing (@$dataset) {
1324            next if ($thing->type !~ /dom/);
1325            my $single_domain = [];
1326            $count++;
1327    
1328            my $db_and_id = $thing->acc;
1329            my ($db,$id) = split("::",$db_and_id);
1330    
1331            my $dbmaster = DBMaster->new(-database =>'Ontology');
1332    
1333            my ($name_title,$name_value,$description_title,$description_value);
1334            if($db eq "CDD"){
1335                my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1336                if(!scalar(@$cdd_objs)){
1337                    $name_title = "name";
1338                    $name_value = "not available";
1339                    $description_title = "description";
1340                    $description_value = "not available";
1341                }
1342                else{
1343                    my $cdd_obj = $cdd_objs->[0];
1344                    $name_title = "name";
1345                    $name_value = $cdd_obj->term;
1346                    $description_title = "description";
1347                    $description_value = $cdd_obj->description;
1348                }
1349            }
1350    
1351            my $location =  $thing->start . " - " . $thing->stop;
1352    
1353            push(@$single_domain,$db);
1354            push(@$single_domain,$thing->acc);
1355            push(@$single_domain,$name_value);
1356            push(@$single_domain,$location);
1357            push(@$single_domain,$thing->evalue);
1358            push(@$single_domain,$description_value);
1359            push(@$data,$single_domain);
1360        }
1361    
1362        if ($count >0){
1363            $content = $data;
1364        }
1365        else
1366        {
1367            $content = "<p>This PEG does not have any similarities to domains</p>";
1368        }
1369    }
1370    
1371    
1372    #########################################
1373    #########################################
1374    package Observation::Location;
1375    
1376    use base qw(Observation);
1377    
1378    sub new {
1379    
1380        my ($class,$dataset) = @_;
1381        my $self = $class->SUPER::new($dataset);
1382        $self->{cleavage_prob} = $dataset->{'cleavage_prob'};
1383        $self->{cleavage_loc} = $dataset->{'cleavage_loc'};
1384        $self->{signal_peptide_score} = $dataset->{'signal_peptide_score'};
1385        $self->{cello_location} = $dataset->{'cello_location'};
1386        $self->{cello_score} = $dataset->{'cello_score'};
1387        $self->{tmpred_score} = $dataset->{'tmpred_score'};
1388        $self->{tmpred_locations} = $dataset->{'tmpred_locations'};
1389        $self->{phobius_signal_location} = $dataset->{'phobius_signal_location'};
1390        $self->{phobius_tm_locations} = $dataset->{'phobius_tm_locations'};
1391    
1392        bless($self,$class);
1393        return $self;
1394    }
1395    
1396    sub display_cello {
1397        my ($thing) = @_;
1398        my $html;
1399        my $cello_location = $thing->cello_location;
1400        my $cello_score = $thing->cello_score;
1401        if($cello_location){
1402            $html .= "<p><font type=verdana size=-2>Subcellular location  prediction: $cello_location, score: $cello_score</font> </p>";
1403            #$html .= "<p>CELLO score: $cello_score </p>";
1404        }
1405        return ($html);
1406    }
1407    
1408    sub display {
1409        my ($thing,$gd) = @_;
1410    
1411        my $fid = $thing->fig_id;
1412        my $fig= new FIG;
1413        my $length = length($fig->get_translation($fid));
1414    
1415        my $cleavage_prob;
1416        if($thing->cleavage_prob){$cleavage_prob = $thing->cleavage_prob;}
1417        my ($cleavage_loc_begin,$cleavage_loc_end) = split("-",$thing->cleavage_loc);
1418        my $signal_peptide_score = $thing->signal_peptide_score;
1419        my $cello_location = $thing->cello_location;
1420        my $cello_score = $thing->cello_score;
1421        my $tmpred_score = $thing->tmpred_score;
1422        my @tmpred_locations = split(",",$thing->tmpred_locations);
1423    
1424        my $phobius_signal_location = $thing->phobius_signal_location;
1425        my @phobius_tm_locations = split(",",$thing->phobius_tm_locations);
1426    
1427        my $lines = [];
1428    
1429        #color is
1430        my $color = "6";
1431    
1432    =pod=
1433    
1434        if($cello_location){
1435            my $cello_descriptions = [];
1436            my $line_data =[];
1437    
1438            my $line_config = { 'title' => 'Localization Evidence',
1439                                'short_title' => 'CELLO',
1440                                'basepair_offset' => '1' };
1441    
1442            my $description_cello_location = {"title" => 'Best Cello Location',
1443                                              "value" => $cello_location};
1444    
1445            push(@$cello_descriptions,$description_cello_location);
1446    
1447            my $description_cello_score = {"title" => 'Cello Score',
1448                                           "value" => $cello_score};
1449    
1450            push(@$cello_descriptions,$description_cello_score);
1451    
1452            my $element_hash = {
1453                "title" => "CELLO",
1454                "color"=> $color,
1455                "start" => "1",
1456                "end" =>  $length + 1,
1457                "zlayer" => '1',
1458                "description" => $cello_descriptions};
1459    
1460            push(@$line_data,$element_hash);
1461            $gd->add_line($line_data, $line_config);
1462        }
1463    
1464        $color = "2";
1465        if($tmpred_score){
1466            my $line_data =[];
1467            my $line_config = { 'title' => 'Localization Evidence',
1468                                'short_title' => 'Transmembrane',
1469                                'basepair_offset' => '1' };
1470    
1471            foreach my $tmpred (@tmpred_locations){
1472                my $descriptions = [];
1473                my ($begin,$end) =split("-",$tmpred);
1474                my $description_tmpred_score = {"title" => 'TMPRED score',
1475                                 "value" => $tmpred_score};
1476    
1477                push(@$descriptions,$description_tmpred_score);
1478    
1479                my $element_hash = {
1480                "title" => "transmembrane location",
1481                "start" => $begin + 1,
1482                "end" =>  $end + 1,
1483                "color"=> $color,
1484                "zlayer" => '5',
1485                "type" => 'box',
1486                "description" => $descriptions};
1487    
1488                push(@$line_data,$element_hash);
1489    
1490            }
1491            $gd->add_line($line_data, $line_config);
1492        }
1493    =cut
1494    
1495        if((scalar(@phobius_tm_locations) > 0) || $phobius_signal_location){
1496            my $line_data =[];
1497            my $line_config = { 'title' => 'Localization Evidence, Transmembrane and Signal Peptide',
1498                                'short_title' => 'TM and SP',
1499                                'basepair_offset' => '1' };
1500    
1501            foreach my $tm_loc (@phobius_tm_locations){
1502                my $descriptions = [];
1503                my $description_phobius_tm_locations = {"title" => 'transmembrane location',
1504                                 "value" => $tm_loc};
1505                push(@$descriptions,$description_phobius_tm_locations);
1506    
1507                my ($begin,$end) =split("-",$tm_loc);
1508    
1509                my $element_hash = {
1510                "title" => "Phobius",
1511                "start" => $begin + 1,
1512                "end" =>  $end + 1,
1513                "color"=> '6',
1514                "zlayer" => '4',
1515                "type" => 'bigbox',
1516                "description" => $descriptions};
1517    
1518                push(@$line_data,$element_hash);
1519    
1520            }
1521    
1522            if($phobius_signal_location){
1523                my $descriptions = [];
1524                my $description_phobius_signal_location = {"title" => 'Phobius Signal Location',
1525                                 "value" => $phobius_signal_location};
1526                push(@$descriptions,$description_phobius_signal_location);
1527    
1528    
1529                my ($begin,$end) =split("-",$phobius_signal_location);
1530                my $element_hash = {
1531                "title" => "phobius signal locations",
1532                "start" => $begin + 1,
1533                "end" =>  $end + 1,
1534                "color"=> '1',
1535                "zlayer" => '5',
1536                "type" => 'box',
1537                "description" => $descriptions};
1538                push(@$line_data,$element_hash);
1539            }
1540    
1541            $gd->add_line($line_data, $line_config);
1542        }
1543    
1544    =head3
1545        $color = "1";
1546        if($signal_peptide_score){
1547            my $line_data = [];
1548            my $descriptions = [];
1549    
1550            my $line_config = { 'title' => 'Localization Evidence',
1551                                'short_title' => 'SignalP',
1552                                'basepair_offset' => '1' };
1553    
1554            my $description_signal_peptide_score = {"title" => 'signal peptide score',
1555                                                    "value" => $signal_peptide_score};
1556    
1557            push(@$descriptions,$description_signal_peptide_score);
1558    
1559            my $description_cleavage_prob = {"title" => 'cleavage site probability',
1560                                             "value" => $cleavage_prob};
1561    
1562            push(@$descriptions,$description_cleavage_prob);
1563    
1564            my $element_hash = {
1565                "title" => "SignalP",
1566                "start" => $cleavage_loc_begin - 2,
1567                "end" =>  $cleavage_loc_end + 1,
1568                "type" => 'bigbox',
1569                "color"=> $color,
1570                "zlayer" => '10',
1571                "description" => $descriptions};
1572    
1573            push(@$line_data,$element_hash);
1574            $gd->add_line($line_data, $line_config);
1575        }
1576    =cut
1577    
1578        return ($gd);
1579    
1580    }
1581    
1582    sub cleavage_loc {
1583      my ($self) = @_;
1584    
1585      return $self->{cleavage_loc};
1586    }
1587    
1588    sub cleavage_prob {
1589      my ($self) = @_;
1590    
1591      return $self->{cleavage_prob};
1592    }
1593    
1594    sub signal_peptide_score {
1595      my ($self) = @_;
1596    
1597      return $self->{signal_peptide_score};
1598    }
1599    
1600    sub tmpred_score {
1601      my ($self) = @_;
1602    
1603      return $self->{tmpred_score};
1604    }
1605    
1606    sub tmpred_locations {
1607      my ($self) = @_;
1608    
1609      return $self->{tmpred_locations};
1610    }
1611    
1612    sub cello_location {
1613      my ($self) = @_;
1614    
1615      return $self->{cello_location};
1616    }
1617    
1618    sub cello_score {
1619      my ($self) = @_;
1620    
1621      return $self->{cello_score};
1622    }
1623    
1624    sub phobius_signal_location {
1625      my ($self) = @_;
1626      return $self->{phobius_signal_location};
1627    }
1628    
1629    sub phobius_tm_locations {
1630      my ($self) = @_;
1631      return $self->{phobius_tm_locations};
1632    }
1633    
1634    
1635    
1636    #########################################
1637    #########################################
1638    package Observation::Sims;
1639    
1640    use base qw(Observation);
1641    
1642    sub new {
1643    
1644        my ($class,$dataset) = @_;
1645        my $self = $class->SUPER::new($dataset);
1646        $self->{identity} = $dataset->{'identity'};
1647        $self->{acc} = $dataset->{'acc'};
1648        $self->{query} = $dataset->{'query'};
1649        $self->{evalue} = $dataset->{'evalue'};
1650        $self->{qstart} = $dataset->{'qstart'};
1651        $self->{qstop} = $dataset->{'qstop'};
1652        $self->{hstart} = $dataset->{'hstart'};
1653        $self->{hstop} = $dataset->{'hstop'};
1654        $self->{database} = $dataset->{'database'};
1655        $self->{organism} = $dataset->{'organism'};
1656        $self->{function} = $dataset->{'function'};
1657        $self->{qlength} = $dataset->{'qlength'};
1658        $self->{hlength} = $dataset->{'hlength'};
1659    
1660        bless($self,$class);
1661        return $self;
1662    }
1663    
1664    =head3 display()
1665    
1666    If available use the function specified here to display a graphical observation.
1667    This code will display a graphical view of the similarities using the genome drawer object
1668    
1669    =cut
1670    
1671    sub display {
1672        my ($self,$gd) = @_;
1673    
1674        my $fig = new FIG;
1675        my $peg = $self->acc;
1676        my $query = $self->query;
1677    
1678        my $organism = $self->organism;
1679        my $genome = $fig->genome_of($peg);
1680        my ($org_tax) = ($genome) =~ /(.*)\./;
1681        my $function = $self->function;
1682        my $abbrev_name = $fig->abbrev($organism);
1683        my $align_start = $self->qstart;
1684        my $align_stop = $self->qstop;
1685        my $hit_start = $self->hstart;
1686        my $hit_stop = $self->hstop;
1687    
1688        my $tax_link = "http://www.ncbi.nlm.nih.gov/Taxonomy/Browser/wwwtax.cgi?id=" . $org_tax;
1689    
1690        my $line_config = { 'title' => "$organism [$org_tax]",
1691                            'short_title' => "$abbrev_name",
1692                            'title_link' => '$tax_link',
1693                            'basepair_offset' => '0'
1694                            };
1695    
1696        my $line_data = [];
1697    
1698        my $element_hash;
1699        my $links_list = [];
1700        my $descriptions = [];
1701    
1702        # get subsystem information
1703        my $url_link = "http://seed-viewer.theseed.org/index.cgi?action=ShowAnnotation&prot=".$peg;
1704    
1705        my $link;
1706        $link = {"link_title" => $peg,
1707                 "link" => $url_link};
1708        push(@$links_list,$link);
1709    
1710        my @subsystems = $fig->peg_to_subsystems($peg);
1711        foreach my $subsystem (@subsystems){
1712            my $link;
1713            $link = {"link" => "http://seed-viewer.theseed.org/index.cgi?action=ShowSubsystem&subsystem_name=$subsystem",
1714                     "link_title" => $subsystem};
1715            push(@$links_list,$link);
1716        }
1717    
1718        $link = {"link_title" => "blast against query",
1719                 "link" => "$FIG_Config::cgi_url/seedviewer.cgi?page=tool_result&tool=bl2seq&peg1=$query&peg2=$peg"};
1720        push (@$links_list,$link);
1721    
1722        my $description_function;
1723        $description_function = {"title" => "function",
1724                                 "value" => $function};
1725        push(@$descriptions,$description_function);
1726    
1727        my ($description_ss, $ss_string);
1728        $ss_string = join (",", @subsystems);
1729        $description_ss = {"title" => "subsystems",
1730                           "value" => $ss_string};
1731        push(@$descriptions,$description_ss);
1732    
1733        my $description_loc;
1734        $description_loc = {"title" => "location start",
1735                            "value" => $hit_start};
1736        push(@$descriptions, $description_loc);
1737    
1738        $description_loc = {"title" => "location stop",
1739                            "value" => $hit_stop};
1740        push(@$descriptions, $description_loc);
1741    
1742        my $evalue = $self->evalue;
1743        while ($evalue =~ /-0/)
1744        {
1745            my ($chunk1, $chunk2) = split(/-/, $evalue);
1746            $chunk2 = substr($chunk2,1);
1747            $evalue = $chunk1 . "-" . $chunk2;
1748        }
1749    
1750        my $color = &color($evalue);
1751    
1752        my $description_eval = {"title" => "E-Value",
1753                                "value" => $evalue};
1754        push(@$descriptions, $description_eval);
1755    
1756        my $identity = $self->identity;
1757        my $description_identity = {"title" => "Identity",
1758                                    "value" => $identity};
1759        push(@$descriptions, $description_identity);
1760    
1761        $element_hash = {
1762            "title" => $peg,
1763            "start" => $align_start,
1764            "end" =>  $align_stop,
1765            "type"=> 'box',
1766            "color"=> $color,
1767            "zlayer" => "2",
1768            "links_list" => $links_list,
1769            "description" => $descriptions
1770            };
1771        push(@$line_data,$element_hash);
1772        $gd->add_line($line_data, $line_config);
1773    
1774        return ($gd);
1775    
1776    }
1777    
1778    =head3 display_domain_composition()
1779    
1780    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
1781    
1782    =cut
1783    
1784    sub display_domain_composition {
1785        my ($self,$gd) = @_;
1786    
1787        my $fig = new FIG;
1788        my $peg = $self->acc;
1789    
1790        my $line_data = [];
1791        my $links_list = [];
1792        my $descriptions = [];
1793    
1794        my @domain_query_results =$fig->get_attributes($peg,"CDD");
1795    
1796        foreach $dqr (@domain_query_results){
1797            my $key = @$dqr[1];
1798            my @parts = split("::",$key);
1799            my $db = $parts[0];
1800            my $id = $parts[1];
1801            my $val = @$dqr[2];
1802            my $from;
1803            my $to;
1804            my $evalue;
1805    
1806            if($val =~/^(\d+\.\d+|0\.0);(\d+)-(\d+)/){
1807                my $raw_evalue = $1;
1808                $from = $2;
1809                $to = $3;
1810                if($raw_evalue =~/(\d+)\.(\d+)/){
1811                    my $part2 = 1000 - $1;
1812                    my $part1 = $2/100;
1813                    $evalue = $part1."e-".$part2;
1814                }
1815                else{
1816                    $evalue = "0.0";
1817                }
1818            }
1819    
1820            my $dbmaster = DBMaster->new(-database =>'Ontology');
1821            my ($name_value,$description_value);
1822    
1823            if($db eq "CDD"){
1824                my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1825                if(!scalar(@$cdd_objs)){
1826                    $name_title = "name";
1827                    $name_value = "not available";
1828                    $description_title = "description";
1829                    $description_value = "not available";
1830                }
1831                else{
1832                    my $cdd_obj = $cdd_objs->[0];
1833                    $name_value = $cdd_obj->term;
1834                    $description_value = $cdd_obj->description;
1835                }
1836            }
1837    
1838            my $domain_name;
1839            $domain_name = {"title" => "name",
1840                     "value" => $name_value};
1841            push(@$descriptions,$domain_name);
1842    
1843            my $description;
1844            $description = {"title" => "description",
1845                            "value" => $description_value};
1846            push(@$descriptions,$description);
1847    
1848            my $score;
1849            $score = {"title" => "score",
1850                      "value" => $evalue};
1851            push(@$descriptions,$score);
1852    
1853            my $link_id = $id;
1854            my $link;
1855            my $link_url;
1856            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"}
1857            elsif($db eq "PFAM"){$link_url = "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?$link_id"}
1858            else{$link_url = "NO_URL"}
1859    
1860            $link = {"link_title" => $name_value,
1861                     "link" => $link_url};
1862            push(@$links_list,$link);
1863    
1864            my $domain_element_hash = {
1865                "title" => $peg,
1866                "start" => $from,
1867                "end" =>  $to,
1868                "type"=> 'box',
1869                "zlayer" => '4',
1870                "links_list" => $links_list,
1871                "description" => $descriptions
1872                };
1873    
1874            push(@$line_data,$domain_element_hash);
1875    
1876            #just one CDD domain for now, later will add option for multiple domains from selected DB
1877            last;
1878        }
1879    
1880        my $line_config = { 'title' => $peg,
1881                            'short_title' => $peg,
1882                            'basepair_offset' => '1' };
1883    
1884        $gd->add_line($line_data, $line_config);
1885    
1886        return ($gd);
1887    
1888    }
1889    
1890    =head3 display_table()
1891    
1892    If available use the function specified here to display the "raw" observation.
1893    This code will display a table for the similarities protein
1894    
1895    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.
1896    
1897    =cut
1898    
1899    sub display_table {
1900        my ($self,$dataset, $scroll_list, $query_fid,$lineages) = @_;
1901    
1902        my $data = [];
1903        my $count = 0;
1904        my $content;
1905        my $fig = new FIG;
1906        my $cgi = new CGI;
1907        my @ids;
1908        foreach my $thing (@$dataset) {
1909            next if ($thing->class ne "SIM");
1910            push (@ids, $thing->acc);
1911        }
1912    
1913        my (%box_column, %subsystems_column, %evidence_column, %e_identical);
1914    
1915        # get the column for the subsystems
1916        %subsystems_column = &get_subsystems_column(\@ids);
1917    
1918        # get the column for the evidence codes
1919        %evidence_column = &get_evidence_column(\@ids);
1920    
1921        # get the column for pfam_domain
1922        %pfam_column = &get_pfam_column(\@ids);
1923    
1924        my %e_identical = &get_essentially_identical($query_fid);
1925        my $all_aliases = $fig->feature_aliases_bulk(\@ids);
1926    
1927        foreach my $thing (@$dataset) {
1928            next if ($thing->class ne "SIM");
1929            my $single_domain = [];
1930            $count++;
1931    
1932            my $id = $thing->acc;
1933    
1934            my $iden    = $thing->identity;
1935            my $ln1     = $thing->qlength;
1936            my $ln2     = $thing->hlength;
1937            my $b1      = $thing->qstart;
1938            my $e1      = $thing->qstop;
1939            my $b2      = $thing->hstart;
1940            my $e2      = $thing->hstop;
1941            my $d1      = abs($e1 - $b1) + 1;
1942            my $d2      = abs($e2 - $b2) + 1;
1943            my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";
1944            my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";
1945    
1946            # checkbox column
1947            my $field_name = "tables_" . $id;
1948            my $pair_name = "visual_" . $id;
1949            my $box_col = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
1950            my ($tax) = ($id) =~ /fig\|(.*?)\./;
1951    
1952            # get the linked fig id
1953            my $fig_col;
1954            if (defined ($e_identical{$id})){
1955                $fig_col = &HTML::set_prot_links($cgi,$id) . "*";
1956            }
1957            else{
1958                $fig_col = &HTML::set_prot_links($cgi,$id);
1959            }
1960    
1961            push(@$single_domain,$box_col);                        # permanent column
1962            push(@$single_domain,$fig_col);                        # permanent column
1963            push(@$single_domain,$thing->evalue);                  # permanent column
1964            push(@$single_domain,"$iden\%");                       # permanent column
1965            push(@$single_domain,$reg1);                           # permanent column
1966            push(@$single_domain,$reg2);                           # permanent column
1967            push(@$single_domain,$thing->organism);                # permanent column
1968            push(@$single_domain,$thing->function);                # permanent column
1969            foreach my $col (sort keys %$scroll_list){
1970                if ($col =~ /associated_subsystem/)          {push(@$single_domain,$subsystems_column{$id});}
1971                elsif ($col =~ /evidence/)                   {push(@$single_domain,$evidence_column{$id});}
1972                elsif ($col =~ /pfam_domains/)               {push(@$single_domain,$pfam_column{$id});}
1973                elsif ($col =~ /ncbi_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'NCBI', $all_aliases));}
1974                elsif ($col =~ /refseq_id/)                  {push(@$single_domain,&get_prefer($thing->acc, 'RefSeq', $all_aliases));}
1975                elsif ($col =~ /swissprot_id/)               {push(@$single_domain,&get_prefer($thing->acc, 'SwissProt', $all_aliases));}
1976                elsif ($col =~ /uniprot_id/)                 {push(@$single_domain,&get_prefer($thing->acc, 'UniProt', $all_aliases));}
1977                elsif ($col =~ /tigr_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'TIGR', $all_aliases));}
1978                elsif ($col =~ /pir_id/)                     {push(@$single_domain,&get_prefer($thing->acc, 'PIR', $all_aliases));}
1979                elsif ($col =~ /kegg_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'KEGG', $all_aliases));}
1980                elsif ($col =~ /trembl_id/)                  {push(@$single_domain,&get_prefer($thing->acc, 'TrEMBL', $all_aliases));}
1981                elsif ($col =~ /asap_id/)                    {push(@$single_domain,&get_prefer($thing->acc, 'ASAP', $all_aliases));}
1982                elsif ($col =~ /jgi_id/)                     {push(@$single_domain,&get_prefer($thing->acc, 'JGI', $all_aliases));}
1983                elsif ($col =~ /taxonomy/)                   {push(@$single_domain,$lineages->{$tax});}
1984            }
1985            push(@$data,$single_domain);
1986        }
1987    
1988        if ($count >0 ){
1989            $content = $data;
1990        }
1991        else{
1992            $content = "<p>This PEG does not have any similarities</p>";
1993        }
1994        return ($content);
1995    }
1996    
1997    sub get_box_column{
1998        my ($ids) = @_;
1999        my %column;
2000        foreach my $id (@$ids){
2001            my $field_name = "tables_" . $id;
2002            my $pair_name = "visual_" . $id;
2003            $column{$id} = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
2004        }
2005        return (%column);
2006    }
2007    
2008    sub get_subsystems_column{
2009        my ($ids) = @_;
2010    
2011        my $fig = new FIG;
2012        my $cgi = new CGI;
2013        my %in_subs  = $fig->subsystems_for_pegs($ids);
2014        my %column;
2015        foreach my $id (@$ids){
2016            my @in_sub = @{$in_subs{$id}} if (defined $in_subs{$id});
2017            my @subsystems;
2018    
2019            if (@in_sub > 0) {
2020                my $count = 1;
2021                foreach my $array(@in_sub){
2022                    push (@subsystems, $count . ". " . $$array[0]);
2023                    $count++;
2024                }
2025                my $in_sub_line = join ("<br>", @subsystems);
2026                $column{$id} = $in_sub_line;
2027            } else {
2028                $column{$id} = "&nbsp;";
2029            }
2030        }
2031        return (%column);
2032    }
2033    
2034    sub get_essentially_identical{
2035        my ($fid) = @_;
2036        my $fig = new FIG;
2037    
2038        my %id_list;
2039        my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);
2040    
2041        foreach my $id (@maps_to) {
2042            if (($id ne $fid) && ($fig->function_of($id))) {
2043                $id_list{$id} = 1;
2044            }
2045        }
2046        return(%id_list);
2047    }
2048    
2049    
2050    sub get_evidence_column{
2051        my ($ids) = @_;
2052        my $fig = new FIG;
2053        my $cgi = new CGI;
2054        my (%column, %code_attributes);
2055    
2056        my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($ids);
2057        foreach my $key (@codes){
2058            push (@{$code_attributes{$$key[0]}}, $key);
2059        }
2060    
2061        foreach my $id (@$ids){
2062            # add evidence code with tool tip
2063            my $ev_codes=" &nbsp; ";
2064            my @ev_codes = "";
2065    
2066            if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {
2067                my @codes;
2068                @codes = @{$code_attributes{$id}} if (defined @{$code_attributes{$id}});
2069                @ev_codes = ();
2070                foreach my $code (@codes) {
2071                    my $pretty_code = $code->[2];
2072                    if ($pretty_code =~ /;/) {
2073                        my ($cd, $ss) = split(";", $code->[2]);
2074                        $ss =~ s/_/ /g;
2075                        $pretty_code = $cd;# . " in " . $ss;
2076                    }
2077                    push(@ev_codes, $pretty_code);
2078                }
2079            }
2080    
2081            if (scalar(@ev_codes) && $ev_codes[0]) {
2082                my $ev_code_help=join("<br />", map {&HTML::evidence_codes_explain($_)} @ev_codes);
2083                $ev_codes = $cgi->a(
2084                                    {
2085                                        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));
2086            }
2087            $column{$id}=$ev_codes;
2088        }
2089        return (%column);
2090    }
2091    
2092    sub get_pfam_column{
2093        my ($ids) = @_;
2094        my $fig = new FIG;
2095        my $cgi = new CGI;
2096        my (%column, %code_attributes, %attribute_locations);
2097        my $dbmaster = DBMaster->new(-database =>'Ontology');
2098    
2099        my @codes = grep { $_->[1] =~ /^PFAM/i } $fig->get_attributes($ids);
2100        foreach my $key (@codes){
2101            push (@{$code_attributes{$$key[0]}}, $$key[1]);
2102            push (@{$attribute_location{$$key[0]}{$$key[1]}}, $$key[2]);
2103        }
2104    
2105        foreach my $id (@$ids){
2106            # add evidence code with tool tip
2107            my $pfam_codes=" &nbsp; ";
2108            my @pfam_codes = "";
2109            my %description_codes;
2110    
2111            if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {
2112                my @ncodes = @{$code_attributes{$id}} if (defined @{$code_attributes{$id}});
2113                @pfam_codes = ();
2114    
2115                # get only unique values
2116                my %saw;
2117                foreach my $key (@ncodes) {$saw{$key}=1;}
2118                @ncodes = keys %saw;
2119    
2120                foreach my $code (@ncodes) {
2121                    my @parts = split("::",$code);
2122                    my $pfam_link = "<a href=http://www.sanger.ac.uk//cgi-bin/Pfam/getacc?" . $parts[1] . ">$parts[1]</a>";
2123    
2124                    # get the locations for the domain
2125                    my @locs;
2126                    foreach my $part (@{$attribute_location{$id}{$code}}){
2127                        my ($loc) = ($part) =~ /\;(.*)/;
2128                        push (@locs,$loc);
2129                    }
2130                    my $locations = join (", ", @locs);
2131    
2132                    if (defined ($description_codes{$parts[1]})){
2133                        push(@pfam_codes, "$parts[1] ($locations)");
2134                    }
2135                    else {
2136                        my $description = $dbmaster->pfam->get_objects( { 'id' => $parts[1] } );
2137                        $description_codes{$parts[1]} = ${$$description[0]}{term};
2138                        push(@pfam_codes, "$pfam_link ($locations)");
2139                    }
2140                }
2141            }
2142    
2143            $column{$id}=join("<br><br>", @pfam_codes);
2144        }
2145        return (%column);
2146    
2147    }
2148    
2149    sub get_prefer {
2150        my ($fid, $db, $all_aliases) = @_;
2151        my $fig = new FIG;
2152        my $cgi = new CGI;
2153    
2154        foreach my $alias (@{$$all_aliases{$fid}}){
2155            my $id_db = &Observation::get_database($alias);
2156            if ($id_db eq $db){
2157                my $acc_col .= &HTML::set_prot_links($cgi,$alias);
2158                return ($acc_col);
2159            }
2160        }
2161        return (" ");
2162    }
2163    
2164    sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
2165    
2166    sub color {
2167        my ($evalue) = @_;
2168        my $color;
2169        if ($evalue <= 1e-170){        $color = 51;    }
2170        elsif (($evalue <= 1e-120) && ($evalue > 1e-170)){        $color = 52;    }
2171        elsif (($evalue <= 1e-90) && ($evalue > 1e-120)){        $color = 53;    }
2172        elsif (($evalue <= 1e-70) && ($evalue > 1e-90)){        $color = 54;    }
2173        elsif (($evalue <= 1e-40) && ($evalue > 1e-70)){        $color = 55;    }
2174        elsif (($evalue <= 1e-20) && ($evalue > 1e-40)){        $color = 56;    }
2175        elsif (($evalue <= 1e-5) && ($evalue > 1e-20)){        $color = 57;    }
2176        elsif (($evalue <= 1) && ($evalue > 1e-5)){        $color = 58;    }
2177        elsif (($evalue <= 10) && ($evalue > 1)){        $color = 59;    }
2178        else{        $color = 60;    }
2179        return ($color);
2180    }
2181    
2182    
2183    ############################
2184    package Observation::Cluster;
2185    
2186    use base qw(Observation);
2187    
2188    sub new {
2189    
2190        my ($class,$dataset) = @_;
2191        my $self = $class->SUPER::new($dataset);
2192        $self->{context} = $dataset->{'context'};
2193        bless($self,$class);
2194        return $self;
2195    }
2196    
2197    sub display {
2198        my ($self,$gd,$selected_taxonomies,$taxes) = @_;
2199    
2200        my $fid = $self->fig_id;
2201        my $compare_or_coupling = $self->context;
2202        my $gd_window_size = $gd->window_size;
2203        my $fig = new FIG;
2204        my $all_regions = [];
2205        my $gene_associations={};
2206    
2207        #get the organism genome
2208        my $target_genome = $fig->genome_of($fid);
2209        $gene_associations->{$fid}->{"organism"} = $target_genome;
2210        $gene_associations->{$fid}->{"main_gene"} = $fid;
2211        $gene_associations->{$fid}->{"reverse_flag"} = 0;
2212    
2213        # get location of the gene
2214        my $data = $fig->feature_location($fid);
2215        my ($contig, $beg, $end);
2216        my %reverse_flag;
2217    
2218        if ($data =~ /(.*)_(\d+)_(\d+)$/){
2219            $contig = $1;
2220            $beg = $2;
2221            $end = $3;
2222        }
2223    
2224        my $offset;
2225        my ($region_start, $region_end);
2226        if ($beg < $end)
2227        {
2228            $region_start = $beg - 4000;
2229            $region_end = $end+4000;
2230            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
2231        }
2232        else
2233        {
2234            $region_start = $end-4000;
2235            $region_end = $beg+4000;
2236            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
2237            $reverse_flag{$target_genome} = $fid;
2238            $gene_associations->{$fid}->{"reverse_flag"} = 1;
2239        }
2240    
2241        # call genes in region
2242        my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_end);
2243        push(@$all_regions,$target_gene_features);
2244        my (@start_array_region);
2245        push (@start_array_region, $offset);
2246    
2247        my %all_genes;
2248        my %all_genomes;
2249        foreach my $feature (@$target_gene_features){ $all_genes{$feature} = $fid; $gene_associations->{$feature}->{"main_gene"}=$fid;}
2250    
2251        if ($compare_or_coupling eq "sims"){
2252            # get the selected boxes
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            if (@selected_taxonomy > 0){
2260                foreach my $sim (@sims){
2261                    next if ($sim->[1] !~ /fig\|/);
2262                    my $genome = $fig->genome_of($sim->[1]);
2263                    my ($genome1) = ($genome) =~ /(.*)\./;
2264                    my $lineage = $taxes->{$genome1};
2265                    #my $lineage = $fig->taxonomy_of($fig->genome_of($sim->[1]));
2266                    foreach my $taxon(@selected_taxonomy){
2267                        if ($lineage =~ /$taxon/){
2268                            push (@selected_sims, $sim->[1]);
2269                        }
2270                    }
2271                    my %saw;
2272                    @selected_sims = grep(!$saw{$_}++, @selected_sims);
2273                }
2274            }
2275            else{
2276                my $simcount = 0;
2277                foreach my $sim (@sims){
2278                    next if ($sim->[1] !~ /fig\|/);
2279                    push (@selected_sims, $sim->[1]);
2280                    $simcount++;
2281                    last if ($simcount > 4);
2282                }
2283            }
2284    
2285            # get the gene context for the sorted matches
2286            foreach my $sim_fid(@selected_sims){
2287                #get the organism genome
2288                my $sim_genome = $fig->genome_of($sim_fid);
2289                $gene_associations->{$sim_fid}->{"organism"} = $sim_genome;
2290                $gene_associations->{$sim_fid}->{"main_gene"} = $sim_fid;
2291                $gene_associations->{$sim_fid}->{"reverse_flag"} = 0;
2292    
2293                # get location of the gene
2294                my $data = $fig->feature_location($sim_fid);
2295                my ($contig, $beg, $end);
2296    
2297                if ($data =~ /(.*)_(\d+)_(\d+)$/){
2298                    $contig = $1;
2299                    $beg = $2;
2300                    $end = $3;
2301                }
2302    
2303                my $offset;
2304                my ($region_start, $region_end);
2305                if ($beg < $end)
2306                {
2307                    $region_start = $beg - 4000;
2308                    $region_end = $end+4000;
2309                    $offset = ($beg+(($end-$beg)/2))-($gd_window_size/2);
2310                }
2311                else
2312                {
2313                    $region_start = $end-4000;
2314                    $region_end = $beg+4000;
2315                    $offset = ($end+(($beg-$end)/2))-($gd_window_size/2);
2316                    $reverse_flag{$sim_genome} = $sim_fid;
2317                    $gene_associations->{$sim_fid}->{"reverse_flag"} = 1;
2318                }
2319    
2320                # call genes in region
2321                my ($sim_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($sim_genome, $contig, $region_start, $region_end);
2322                push(@$all_regions,$sim_gene_features);
2323                push (@start_array_region, $offset);
2324                foreach my $feature (@$sim_gene_features){ $all_genes{$feature} = $sim_fid;$gene_associations->{$feature}->{"main_gene"}=$sim_fid;}
2325                $all_genomes{$sim_genome} = 1;
2326            }
2327    
2328        }
2329    
2330        # cluster the genes
2331        my @all_pegs = keys %all_genes;
2332        my $color_sets = &cluster_genes($fig,\@all_pegs,$fid);
2333    
2334        foreach my $region (@$all_regions){
2335            my $sample_peg = @$region[0];
2336            my $region_genome = $fig->genome_of($sample_peg);
2337            my $region_gs = $fig->genus_species($region_genome);
2338            my $abbrev_name = $fig->abbrev($region_gs);
2339            my ($genome1) = ($region_genome) =~ /(.*?)\./;
2340            my $lineage = $taxes->{$genome1};
2341            #$region_gs .= "Lineage:$lineage";
2342            my $line_config = { 'title' => $region_gs,
2343                                'short_title' => $abbrev_name,
2344                                'basepair_offset' => '0'
2345                                };
2346    
2347            my $offsetting = shift @start_array_region;
2348    
2349            my $second_line_config = { 'title' => "$lineage",
2350                                       'short_title' => "",
2351                                       'basepair_offset' => '0',
2352                                       'no_middle_line' => '1'
2353                                       };
2354    
2355            my $line_data = [];
2356            my $second_line_data = [];
2357    
2358            # initialize variables to check for overlap in genes
2359            my ($prev_start, $prev_stop, $prev_fig, $second_line_flag);
2360            my $major_line_flag = 0;
2361            my $prev_second_flag = 0;
2362    
2363            foreach my $fid1 (@$region){
2364                $second_line_flag = 0;
2365                my $element_hash;
2366                my $links_list = [];
2367                my $descriptions = [];
2368    
2369                my $color = $color_sets->{$fid1};
2370    
2371                # get subsystem information
2372                my $function = $fig->function_of($fid1);
2373                my $url_link = "http://seed-viewer.theseed.org/index.cgi?action=ShowAnnotation&prot=".$fid1;
2374    
2375                my $link;
2376                $link = {"link_title" => $fid1,
2377                         "link" => $url_link};
2378                push(@$links_list,$link);
2379    
2380                my @subsystems = $fig->peg_to_subsystems($fid1);
2381                foreach my $subsystem (@subsystems){
2382                    my $link;
2383                    $link = {"link" => "http://seed-viewer.theseed.org/index.cgi?action=ShowSubsystem&subsystem_name=$subsystem",
2384                             "link_title" => $subsystem};
2385                    push(@$links_list,$link);
2386                }
2387    
2388                my $description_function;
2389                $description_function = {"title" => "function",
2390                                         "value" => $function};
2391                push(@$descriptions,$description_function);
2392    
2393                my $description_ss;
2394                my $ss_string = join (",", @subsystems);
2395                $description_ss = {"title" => "subsystems",
2396                                   "value" => $ss_string};
2397                push(@$descriptions,$description_ss);
2398    
2399    
2400                my $fid_location = $fig->feature_location($fid1);
2401                if($fid_location =~/(.*)_(\d+)_(\d+)$/){
2402                    my($start,$stop);
2403                    $start = $2 - $offsetting;
2404                    $stop = $3 - $offsetting;
2405    
2406                    if ( (($prev_start) && ($prev_stop) ) &&
2407                         ( ($start < $prev_start) || ($start < $prev_stop) ||
2408                           ($stop < $prev_start) || ($stop < $prev_stop) )){
2409                        if (($second_line_flag == 0) && ($prev_second_flag == 0)) {
2410                            $second_line_flag = 1;
2411                            $major_line_flag = 1;
2412                        }
2413                    }
2414                    $prev_start = $start;
2415                    $prev_stop = $stop;
2416                    $prev_fig = $fid1;
2417    
2418                    if ((defined($reverse_flag{$region_genome})) && ($reverse_flag{$region_genome} eq $all_genes{$fid1})){
2419                        $start = $gd_window_size - $start;
2420                        $stop = $gd_window_size - $stop;
2421                    }
2422    
2423                    $element_hash = {
2424                        "title" => $fid1,
2425                        "start" => $start,
2426                        "end" =>  $stop,
2427                        "type"=> 'arrow',
2428                        "color"=> $color,
2429                        "zlayer" => "2",
2430                        "links_list" => $links_list,
2431                        "description" => $descriptions
2432                    };
2433    
2434                    # if there is an overlap, put into second line
2435                    if ($second_line_flag == 1){ push(@$second_line_data,$element_hash); $prev_second_flag = 1;}
2436                    else{ push(@$line_data,$element_hash); $prev_second_flag = 0;}
2437                }
2438            }
2439            $gd->add_line($line_data, $line_config);
2440            $gd->add_line($second_line_data, $second_line_config); # if ($major_line_flag == 1);
2441        }
2442        return $gd;
2443    }
2444    
2445    sub cluster_genes {
2446        my($fig,$all_pegs,$peg) = @_;
2447        my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
2448    
2449        my @color_sets = ();
2450    
2451        $conn = &get_connections_by_similarity($fig,$all_pegs);
2452    
2453        for ($i=0; ($i < @$all_pegs); $i++) {
2454            if ($all_pegs->[$i] eq $peg) { $pegI = $i }
2455            if (! $seen{$i}) {
2456                $cluster = [$i];
2457                $seen{$i} = 1;
2458                for ($j=0; ($j < @$cluster); $j++) {
2459                    $x = $conn->{$cluster->[$j]};
2460                    foreach $k (@$x) {
2461                        if (! $seen{$k}) {
2462                            push(@$cluster,$k);
2463                            $seen{$k} = 1;
2464                        }
2465                    }
2466                }
2467    
2468                if ((@$cluster > 1) || ($cluster->[0] eq $pegI)) {
2469                    push(@color_sets,$cluster);
2470                }
2471            }
2472        }
2473        for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
2474        $red_set = $color_sets[$i];
2475        splice(@color_sets,$i,1);
2476        @color_sets = sort { @$b <=> @$a } @color_sets;
2477        unshift(@color_sets,$red_set);
2478    
2479        my $color_sets = {};
2480        for ($i=0; ($i < @color_sets); $i++) {
2481            foreach $x (@{$color_sets[$i]}) {
2482                $color_sets->{$all_pegs->[$x]} = $i;
2483            }
2484        }
2485        return $color_sets;
2486    }
2487    
2488    sub get_connections_by_similarity {
2489        my($fig,$all_pegs) = @_;
2490        my($i,$j,$tmp,$peg,%pos_of);
2491        my($sim,%conn,$x,$y);
2492    
2493        for ($i=0; ($i < @$all_pegs); $i++) {
2494            $tmp = $fig->maps_to_id($all_pegs->[$i]);
2495            push(@{$pos_of{$tmp}},$i);
2496            if ($tmp ne $all_pegs->[$i]) {
2497                push(@{$pos_of{$all_pegs->[$i]}},$i);
2498            }
2499        }
2500    
2501        foreach $y (keys(%pos_of)) {
2502            $x = $pos_of{$y};
2503            for ($i=0; ($i < @$x); $i++) {
2504                for ($j=$i+1; ($j < @$x); $j++) {
2505                    push(@{$conn{$x->[$i]}},$x->[$j]);
2506                    push(@{$conn{$x->[$j]}},$x->[$i]);
2507                }
2508            }
2509        }
2510    
2511        for ($i=0; ($i < @$all_pegs); $i++) {
2512            foreach $sim ($fig->nsims($all_pegs->[$i],500,10,"raw")) {
2513                if (defined($x = $pos_of{$sim->id2})) {
2514                    foreach $y (@$x) {
2515                        push(@{$conn{$i}},$y);
2516                    }
2517                }
2518            }
2519        }
2520        return \%conn;
2521    }
2522    
2523    sub in {
2524        my($x,$xL) = @_;
2525        my($i);
2526    
2527        for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
2528        return ($i < @$xL);
2529    }

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.40

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3