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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3