[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.75, Thu Feb 5 18:54:17 2009 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 get_sims_objects);
9    
10  use strict;  use WebColors;
11  use warnings;  use WebConfig;
 use Table;  
12    
13  1;  use FIG_Config;
14    use LWP::Simple;
15    #use strict;
16    #use warnings;
17    use HTML;
18    use FFs;
19    
20  # $Id$  1;
21    
22  =head1 NAME  =head1 NAME
23    
# Line 22  Line 30 
30    
31  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).
32    
 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  
   
33  =cut  =cut
34    
35  =head1 BACKGROUND  =head1 BACKGROUND
# Line 65  Line 53 
53    
54  The public methods this package provides are listed below:  The public methods this package provides are listed below:
55    
56    
57    =head3 context()
58    
59    Returns close or diverse for purposes of displaying genomic context
60    
61    =cut
62    
63    sub context {
64      my ($self) = @_;
65    
66      return $self->{context};
67    }
68    
69    =head3 rows()
70    
71    each row in a displayed table
72    
73    =cut
74    
75    sub rows {
76      my ($self) = @_;
77    
78      return $self->{rows};
79    }
80    
81  =head3 acc()  =head3 acc()
82    
83  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 86 
86    
87  sub acc {  sub acc {
88    my ($self) = @_;    my ($self) = @_;
   
89    return $self->{acc};    return $self->{acc};
90  }  }
91    
92  =head3 description()  =head3 query()
   
 The description of the hit. Taken from the data or from the our Ontology database for some cases e.g. IPR or PFAM.  
93    
94  B<Please note:>  The query id
 Either remoteid or description is required.  
95    
96  =cut  =cut
97    
98  sub description {  sub query {
99    my ($self) = @_;    my ($self) = @_;
100        return $self->{query};
   return $self->{description};  
101  }  }
102    
103    
104  =head3 class()  =head3 class()
105    
106  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 110 
110    
111  =over 9  =over 9
112    
113    =item IDENTICAL (seq)
114    
115  =item SIM (seq)  =item SIM (seq)
116    
117  =item BBH (seq)  =item BBH (seq)
# Line 115  Line 126 
126    
127  =item PFAM (dom)  =item PFAM (dom)
128    
129  =item SIGNALP (dom)  =item SIGNALP_CELLO_TMPRED (loc)
130    
131  =item  CELLO(loc)  =item PDB (seq)
132    
133  =item TMHMM (loc)  =item TMHMM (loc)
134    
# Line 156  Line 167 
167  sub type {  sub type {
168    my ($self) = @_;    my ($self) = @_;
169    
170    return $self->{acc};    return $self->{type};
171  }  }
172    
173  =head3 start()  =head3 start()
# Line 183  Line 194 
194    return $self->{stop};    return $self->{stop};
195  }  }
196    
197  =head3 evalue()  =head3 start()
198    
199  E-value or P-Value if present.  Start of hit in query sequence.
200    
201  =cut  =cut
202    
203  sub evalue {  sub qstart {
204    my ($self) = @_;    my ($self) = @_;
205    
206    return $self->{evalue};      return $self->{qstart};
207  }  }
208    
209  =head3 score()  =head3 qstop()
   
 Score if present.  
210    
211  B<Please note: >  End of the hit in query sequence.
 Either score or eval are required.  
212    
213  =cut  =cut
214    
215  sub score {  sub qstop {
216    my ($self) = @_;    my ($self) = @_;
217    return $self->{score};  
218        return $self->{qstop};
219  }  }
220    
221    =head3 hstart()
222    
223  =head3 display_method()  Start of hit in hit sequence.
224    
225  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".  
226    
227  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 {
228        my ($self) = @_;
229    
230  =cut      return $self->{hstart};
231    }
232    
233  sub display {  =head3 end()
234    
235    die "Abstract Method Called\n";  End of the hit in hit sequence.
236    
237  }  =cut
238    
239    sub hstop {
240        my ($self) = @_;
241    
242  =head3 rank()      return $self->{hstop};
243    }
244    
245  Returns an integer from 1 - 10 indicating the importance of this observations.  =head3 qlength()
246    
247  Currently always returns 1.  length of the query sequence in similarities
248    
249  =cut  =cut
250    
251  sub rank {  sub qlength {
252    my ($self) = @_;    my ($self) = @_;
253    
254  #  return $self->{rank};      return $self->{qlength};
   
   return 1;  
255  }  }
256    
257  =head3 supports_annotation()  =head3 hlength()
   
 Does a this observation support the annotation of its feature?  
258    
259  Returns  length of the hit sequence in similarities
260    
261  =over 3  =cut
262    
263  =item 10, if feature annotation is identical to $self->description  sub hlength {
264        my ($self) = @_;
265    
266  =item 1, Feature annotation is similar to $self->annotation; this is computed using FIG::SameFunc()      return $self->{hlength};
267    }
268    
269  =item undef  =head3 evalue()
270    
271  =back  E-value or P-Value if present.
272    
273  =cut  =cut
274    
275  sub supports_annotation {  sub evalue {
276    my ($self) = @_;    my ($self) = @_;
277    
278    # no code here so far    return $self->{evalue};
   
   return $self->{supports_annotation};  
279  }  }
280    
281  =head3 url()  =head3 score()
282    
283  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.
284    
285  =cut  =cut
286    
287  sub url {  sub score {
288    my ($self) = @_;    my ($self) = @_;
289      return $self->{score};
290    }
291    
292    =head3 display()
293    
294    will be different for each type
295    
296    =cut
297    
298    my $url = get_url($self->type, $self->acc);  sub display {
299    
300      die "Abstract Method Called\n";
301    
   return $url;  
302  }  }
303    
304  =head3 get_objects()  =head3 display_table()
305    
306  This is the B<REAL WORKHORSE> method of this Package.  will be different for each type
307    
308    =cut
309    
310    sub display_table {
311    
312  It will probably have to:    die "Abstract Table Method Called\n";
313    
 - 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;  
314   }   }
315    
316  It will invoke the required calls to the SEED API to retrieve the information required.  =head3 get_objects()
317    
318    This is the B<REAL WORKHORSE> method of this Package.
319    
320  =cut  =cut
321    
322  sub get_objects {  sub get_objects {
323      my ($self,$fid,$classes) = @_;      my ($self,$fid,$fig,$parameters,$scope) = @_;
   
324    
325      my $objects = [];      my $objects = [];
326      my @matched_datasets=();      my @matched_datasets=();
# Line 327  Line 328 
328      # call function that fetches attribute based observations      # call function that fetches attribute based observations
329      # returns an array of arrays of hashes      # returns an array of arrays of hashes
330    
331      if(scalar(@$classes) < 1){      if($scope){
332          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);  
333      }      }
334      else{      else{
         #IPR,CDD,CELLO,PFAM,SIGNALP - attribute based  
335          my %domain_classes;          my %domain_classes;
336          foreach my $class (@$classes){          my @attributes = $fig->get_attributes($fid);
337              if($class =~/(IPR|CDD|PFAM)/){          #$domain_classes{'CDD'} = 1;
338                  $domain_classes{$class} = 1;          $domain_classes{'PFAM'} = 1;
339            get_identical_proteins($fid,\@matched_datasets,$fig);
340              }          get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets,\@attributes,$fig);
341          }          get_sims_observations($fid,\@matched_datasets,$fig,$parameters);
342          get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets);          get_functional_coupling($fid,\@matched_datasets,$fig);
343            get_attribute_based_location_observations($fid,\@matched_datasets,\@attributes,$fig);
344          #add CELLO and SignalP later          get_pdb_observations($fid,\@matched_datasets,\@attributes,$fig);
345      }      }
346    
347      foreach my $dataset (@matched_datasets) {      foreach my $dataset (@matched_datasets) {
# Line 352  Line 349 
349          if($dataset->{'type'} eq "dom"){          if($dataset->{'type'} eq "dom"){
350              $object = Observation::Domain->new($dataset);              $object = Observation::Domain->new($dataset);
351          }          }
352            elsif($dataset->{'class'} eq "PCH"){
353                $object = Observation::FC->new($dataset);
354            }
355            elsif ($dataset->{'class'} eq "IDENTICAL"){
356                $object = Observation::Identical->new($dataset);
357            }
358            elsif ($dataset->{'class'} eq "SIGNALP_CELLO_TMPRED"){
359                $object = Observation::Location->new($dataset);
360            }
361            elsif ($dataset->{'class'} eq "SIM"){
362                $object = Observation::Sims->new($dataset);
363            }
364            elsif ($dataset->{'class'} eq "CLUSTER"){
365                $object = Observation::Cluster->new($dataset);
366            }
367            elsif ($dataset->{'class'} eq "PDB"){
368                $object = Observation::PDB->new($dataset);
369            }
370    
371          push (@$objects, $object);          push (@$objects, $object);
372      }      }
373    
# Line 359  Line 375 
375    
376  }  }
377    
378  =head1 Internal Methods  =head3 get_attributes
379        provides layer of abstraction between tools and underlying access method to Attribute Server
380    =cut
381    
382  These methods are not meant to be used outside of this package.  sub get_attributes{
383        my ($self,$fig,$search_set,$search_term,$value_array_ref) = @_;
384        my @attributes = $fig->get_attributes($search_set,$search_term,@$value_array_ref);
385        return @attributes;
386    }
387    
388  B<Please do not use them outside of this package!>  =head3 get_sims_objects()
389    
390    This is the B<REAL WORKHORSE> method of this Package.
391    
392  =cut  =cut
393    
394    sub get_sims_objects {
395        my ($self,$fid,$fig,$parameters) = @_;
396    
397        my $objects = [];
398        my @matched_datasets=();
399    
400  =head3 get_url (internal)      # call function that fetches attribute based observations
401        # returns an array of arrays of hashes
402        get_sims_observations($fid,\@matched_datasets,$fig,$parameters);
403    
404  get_url() return a valid URL or undef for any observation.      foreach my $dataset (@matched_datasets) {
405            my $object;
406            if ($dataset->{'class'} eq "SIM"){
407                $object = Observation::Sims->new($dataset);
408            }
409            push (@$objects, $object);
410        }
411        return $objects;
412    }
413    
 URLs are constructed by looking at the Accession acc()  and  name()  
414    
415  Info from both attributes is combined with a table of base URLs stored in this function.  =head3 display_housekeeping
416    This method returns the housekeeping data for a given peg in a table format
417    
418  =cut  =cut
419    sub display_housekeeping {
420        my ($self,$fid,$fig) = @_;
421        my $content = [];
422        my $row = [];
423    
424        my $org_name = "Data not available";
425        if ( $fig->org_of($fid)){
426            $org_name = $fig->org_of($fid);
427        }
428        my $org_id = $fig->genome_of($fid);
429        my $function = $fig->function_of($fid);
430        #my $taxonomy = $fig->taxonomy_of($org_id);
431        my $length = $fig->translation_length($fid);
432    
433        push (@$row, $org_name);
434        push (@$row, $fid);
435        push (@$row, $length);
436        push (@$row, $function);
437    
438        # initialize the table for commentary and annotations
439        #$content .= qq(<b>My Sequence Data</b><br><table border="0">);
440        #$content .= qq(<tr width=15%><td >FIG ID</td><td>$fid</td></tr>\n);
441        #$content .= qq(<tr width=15%><td >Organism Name</td><td>$org_name</td></tr>\n);
442        #$content .= qq(<tr><td width=15%>Taxonomy</td><td>$taxonomy</td></tr>\n);
443        #$content .= qq(<tr width=15%><td>Function</td><td>$function</td></tr>\n);
444        #$content .= qq(<tr width=15%><td>Sequence Length</td><td>$length aa</td></tr>\n);
445        #$content .= qq(</table><p>\n);
446    
447  sub get_url {      push(@$content, $row);
448    
449   my ($self) = @_;      return ($content);
450   my $url='';  }
451    
452  # a hash with a URL for each observation; identified by name()  =head3 get_sims_summary
453  #my $URL             => { 'PFAM' => "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?" ,\  This method uses as input the similarities of a peg and creates a tree view of their taxonomy
 #                       '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="  
 #};  
454    
455  # if (defined $URL{$self->name}) {  =cut
456  #     $url = $URL{$self->name}.$self->acc;  
457  #     return $url;  sub get_sims_summary {
458  # }      my ($observation, $dataset, $fig) = @_;
459  # else      my %families;
460       return undef;      my $taxes = $fig->taxonomy_list();
461    
462        foreach my $thing (@$dataset) {
463            my ($id, $evalue);
464            if ($thing =~ /fig\|/){
465                $id = $thing;
466                $evalue = -1;
467            }
468            else{
469                next if ($thing->class ne "SIM");
470                $id      = $thing->acc;
471                $evalue  = $thing->evalue;
472            }
473            next if ($id !~ /fig\|/);
474            next if ($fig->is_deleted_fid($id));
475    
476            my $genome = $fig->genome_of($id);
477            #my ($genome1) = ($genome) =~ /(.*)\./;
478            my $taxonomy = $taxes->{$genome};
479            my $parent_tax = "Root";
480            my @currLineage = ($parent_tax);
481            push (@{$families{figs}{$parent_tax}}, $id);
482            my $level = 2;
483    
484            foreach my $tax (split(/\; /, $taxonomy),$id){
485              next if ($tax eq $parent_tax);
486              push (@{$families{children}{$parent_tax}}, $tax) if ($tax ne $parent_tax);
487              push (@{$families{figs}{$tax}}, $id) if ($tax ne $parent_tax);
488              $families{level}{$tax} = $level;
489              push (@currLineage, $tax);
490              $families{parent}{$tax} = $parent_tax;
491              $families{lineage}{$tax} = join(";", @currLineage);
492              if (defined ($families{evalue}{$tax})){
493                if ($evalue < $families{evalue}{$tax}){
494                  $families{evalue}{$tax} = $evalue;
495                  $families{color}{$tax} = &get_taxcolor($evalue);
496                }
497              }
498              else{
499                $families{evalue}{$tax} = $evalue;
500                $families{color}{$tax} = &get_taxcolor($evalue);
501  }  }
502    
503  =head3 get_display_method (internal)            $parent_tax = $tax;
504              $level++;
505            }
506        }
507    
508  get_display_method() return a valid URL or undef for any observation.      foreach my $key (keys %{$families{children}}){
509            $families{count}{$key} = @{$families{children}{$key}};
510    
511  URLs are constructed by looking at the Accession acc()  and  name()          my %saw;
512  and Info from both attributes is combined with a table of base URLs stored in this function.          my @out = grep(!$saw{$_}++, @{$families{children}{$key}});
513            $families{children}{$key} = \@out;
514        }
515    
516  =cut      return \%families;
517    }
518    
519  sub get_display_method {  =head1 Internal Methods
520    
521   my ($self) = @_;  These methods are not meant to be used outside of this package.
522    
523  # a hash with a URL for each observation; identified by name()  B<Please do not use them outside of this package!>
 #my $URL             => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\  
 #                        'bbh'=> "http://www.theseed.org/featalign.cgi?id1="  
 # };  
524    
525  #if (defined $URL{$self->name}) {  =cut
526  #     $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc;  
527  #     return $url;  sub get_taxcolor{
528  # }      my ($evalue) = @_;
529  # else      my $color;
530       return undef;      if ($evalue == -1){            $color = "black";      }
531        elsif (($evalue <= 1e-170) && ($evalue >= 0)){        $color = "#FF2000";    }
532        elsif (($evalue <= 1e-120) && ($evalue > 1e-170)){        $color = "#FF3300";    }
533        elsif (($evalue <= 1e-90) && ($evalue > 1e-120)){        $color = "#FF6600";    }
534        elsif (($evalue <= 1e-70) && ($evalue > 1e-90)){        $color = "#FF9900";    }
535        elsif (($evalue <= 1e-40) && ($evalue > 1e-70)){        $color = "#FFCC00";    }
536        elsif (($evalue <= 1e-20) && ($evalue > 1e-40)){        $color = "#FFFF00";    }
537        elsif (($evalue <= 1e-5) && ($evalue > 1e-20)){        $color = "#CCFF00";    }
538        elsif (($evalue <= 1) && ($evalue > 1e-5)){        $color = "#66FF00";    }
539        elsif (($evalue <= 10) && ($evalue > 1)){        $color = "#00FF00";    }
540        else{        $color = "#6666FF";    }
541        return ($color);
542  }  }
543    
544    
545  sub get_attribute_based_domain_observations{  sub get_attribute_based_domain_observations{
546    
547      # 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)
548      my ($fid,$domain_classes,$datasets_ref) = (@_);      my ($fid,$domain_classes,$datasets_ref,$attributes_ref,$fig) = (@_);
549        my $seen = {};
550      my $fig = new FIG;      foreach my $attr_ref (@$attributes_ref) {
   
     foreach my $attr_ref ($fig->get_attributes($fid)) {  
551          my $key = @$attr_ref[1];          my $key = @$attr_ref[1];
552          my @parts = split("::",$key);          my @parts = split("::",$key);
553          my $class = $parts[0];          my $class = $parts[0];
554            my $name = $parts[1];
555            next if ($seen->{$name});
556            $seen->{$name}++;
557            #next if (($class eq "PFAM") && ($name !~ /interpro/));
558    
559          if($domain_classes->{$parts[0]}){          if($domain_classes->{$parts[0]}){
560              my $val = @$attr_ref[2];              my $val = @$attr_ref[2];
# Line 447  Line 563 
563                  my $from = $2;                  my $from = $2;
564                  my $to = $3;                  my $to = $3;
565                  my $evalue;                  my $evalue;
566                  if($raw_evalue =~/(\d+)\.(\d+)/){                  if(($raw_evalue =~/(\d+)\.(\d+)/) && ($class ne "PFAM")){
567                        my $part2 = 1000 - $1;
568                        my $part1 = $2/100;
569                        $evalue = $part1."e-".$part2;
570                    }
571                    elsif(($raw_evalue =~/(\d+)\.(\d+)/) && ($class eq "PFAM")){
572                        #$evalue=$raw_evalue;
573                      my $part2 = 1000 - $1;                      my $part2 = 1000 - $1;
574                      my $part1 = $2/100;                      my $part1 = $2/100;
575                      $evalue = $part1."e-".$part2;                      $evalue = $part1."e-".$part2;
576    
577                  }                  }
578                  else{                  else{
579                      $evalue = "0.0";                      $evalue = "0.0";
# Line 461  Line 584 
584                                 'type' => "dom" ,                                 'type' => "dom" ,
585                                 'evalue' => $evalue,                                 'evalue' => $evalue,
586                                 'start' => $from,                                 'start' => $from,
587                                 'stop' => $to                                 'stop' => $to,
588                                   'fig_id' => $fid,
589                                   'score' => $raw_evalue
590                                 };                                 };
591    
592                  push (@{$datasets_ref} ,$dataset);                  push (@{$datasets_ref} ,$dataset);
# Line 470  Line 595 
595      }      }
596  }  }
597    
598  =head3 get_attribute_based_evidence (internal)  sub get_attribute_based_location_observations{
599    
600  This method retrieves evidence from the attribute server      my ($fid,$datasets_ref, $attributes_ref,$fig) = (@_);
601        #my $fig = new FIG;
602    
603  =cut      my $location_attributes = ['SignalP','CELLO','TMPRED','Phobius'];
604    
605  sub get_attribute_based_observations{      my $dataset = {'type' => "loc",
606                       'class' => 'SIGNALP_CELLO_TMPRED',
607                       'fig_id' => $fid
608                       };
609    
610      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)      foreach my $attr_ref (@$attributes_ref){
611      my ($fid,$datasets_ref) = (@_);          my $key = @$attr_ref[1];
612            next if (($key !~ /SignalP/) && ($key !~ /CELLO/) && ($key !~ /TMPRED/)  && ($key !~/Phobius/) );
613            my @parts = split("::",$key);
614            my $sub_class = $parts[0];
615            my $sub_key = $parts[1];
616            my $value = @$attr_ref[2];
617            if($sub_class eq "SignalP"){
618                if($sub_key eq "cleavage_site"){
619                    my @value_parts = split(";",$value);
620                    $dataset->{'cleavage_prob'} = $value_parts[0];
621                    $dataset->{'cleavage_loc'} = $value_parts[1];
622                }
623                elsif($sub_key eq "signal_peptide"){
624                    $dataset->{'signal_peptide_score'} = $value;
625                }
626            }
627    
628      my $_myfig = new FIG;          elsif($sub_class eq "CELLO"){
629                $dataset->{'cello_location'} = $sub_key;
630                $dataset->{'cello_score'} = $value;
631            }
632    
633      foreach my $attr_ref ($_myfig->get_attributes($fid)) {          elsif($sub_class eq "Phobius"){
634                if($sub_key eq "transmembrane"){
635                    $dataset->{'phobius_tm_locations'} = $value;
636                }
637                elsif($sub_key eq "signal"){
638                    $dataset->{'phobius_signal_location'} = $value;
639                }
640            }
641    
642          # convert the ref into a string for easier handling          elsif($sub_class eq "TMPRED"){
643          my ($string) = "@$attr_ref";              my @value_parts = split(/\;/,$value);
644                $dataset->{'tmpred_score'} = $value_parts[0];
645                $dataset->{'tmpred_locations'} = $value_parts[1];
646            }
647        }
648    
649  #       print "S:$string\n";      push (@{$datasets_ref} ,$dataset);
         my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/);  
650    
651          # THIS SHOULD BE DONE ANOTHER WAY FM->TD  }
         # we need to do the right thing for each type, ie no evalue for CELLO and no coordinates, but a score, etc  
         # as fas as possible this should be configured so that the type of observation and the regexp are  
         # stored somewhere for easy expansion  
         #  
652    
653          if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) {  =head3 get_pdb_observations() (internal)
654    
655              # some keys are composite CDD::1233244 or PFAM:PF1233  This methods sets the type and class for pdb observations
656    
657              if ( $key =~ /::/ ) {  =cut
                 my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/);  
                 $val=$restkey.";".$val;  
                 $key=$firstkey;  
             }  
658    
659              my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ );  sub get_pdb_observations{
660        my ($fid,$datasets_ref, $attributes_ref,$fig) = (@_);
661    
662              my $evalue= 255;      #my $fig = new FIG;
             if (defined $raw_evalue) { # some of the tool do not give us an evalue  
663    
664                  my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/);      foreach my $attr_ref (@$attributes_ref){
665                  my ($new_k, $new_exp);          my $key = @$attr_ref[1];
666            next if ( ($key !~ /PDB/));
667            my($key1,$key2) =split("::",$key);
668            my $value = @$attr_ref[2];
669            my ($evalue,$location) = split(";",$value);
670    
671                  #          if($evalue =~/(\d+)\.(\d+)/){
672                  #  THIS DOES NOT WORK PROPERLY              my $part2 = 1000 - $1;
673                  #              my $part1 = $2/100;
674                  if($raw_evalue =~/(\d+).(\d+)/){              $evalue = $part1."e-".$part2;
675            }
676    
677  #                   $new_exp = (1000+$expo);          my($start,$stop) =split("-",$location);
         #           $new_k = $k / 100;  
678    
679            my $url = @$attr_ref[3];
680            my $dataset = {'class' => 'PDB',
681                           'type' => 'seq' ,
682                           'acc' => $key2,
683                           'evalue' => $evalue,
684                           'start' => $start,
685                           'stop' => $stop,
686                           'fig_id' => $fid
687                           };
688    
689            push (@{$datasets_ref} ,$dataset);
690                  }                  }
                 $evalue = "0.01"#new_k."e-".$new_exp;  
691              }              }
692    
693              # unroll it all into an array of hashes  =head3 get_cluster_observations() (internal)
             # this needs to be done differently for different types of observations  
             my $dataset = [ { name => 'class', value => $key },  
                             { name => 'acc' , value => $acc},  
                             { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD  
                             { name => 'evalue', value => $evalue },  
                             { name => 'start', value => $from},  
                             { name => 'stop' , value => $to}  
                             ];  
694    
695    This methods sets the type and class for cluster observations
696    
697    =cut
698    
699    sub get_cluster_observations{
700        my ($fid,$datasets_ref,$scope) = (@_);
701    
702        my $dataset = {'class' => 'CLUSTER',
703                       'type' => 'fc',
704                       'context' => $scope,
705                       'fig_id' => $fid
706                       };
707              push (@{$datasets_ref} ,$dataset);              push (@{$datasets_ref} ,$dataset);
708          }          }
709      }  
 }  
710    
711  =head3 get_sims_observations() (internal)  =head3 get_sims_observations() (internal)
712    
# Line 549  Line 715 
715  =cut  =cut
716    
717  sub get_sims_observations{  sub get_sims_observations{
718        my ($fid,$datasets_ref,$fig,$parameters) = (@_);
719    
720      my ($fid,$datasets_ref) = (@_);      my ($max_sims, $max_expand, $max_eval, $sim_order, $db_filter, $sim_filters);
721      my $fig = new FIG;      if ( (defined $parameters->{flag}) && ($parameters->{flag})){
722      my @sims= $fig->nsims($fid,100,1e-20,"fig");        $max_sims = $parameters->{max_sims};
723          $max_expand = $parameters->{max_expand};
724          $max_eval = $parameters->{max_eval};
725          $db_filter = $parameters->{db_filter};
726          $sim_filters->{ sort_by } = $parameters->{sim_order};
727          #$sim_order = $parameters->{sim_order};
728          $group_by_genome = 1 if (defined ($parameters->{group_genome}));
729        }
730        elsif ( (defined $parameters->{sims_db}) && ($parameters->{sims_db} eq 'all')){
731          $max_sims = 50;
732          $max_expand = 5;
733          $max_eval = 1e-5;
734          $db_filter = "all";
735          $sim_filters->{ sort_by } = 'id';
736        }
737        else{
738          $max_sims = 50;
739          $max_expand = 5;
740          $max_eval = 1e-5;
741          $db_filter = "figx";
742          $sim_filters->{ sort_by } = 'id';
743          #$sim_order = "id";
744        }
745    
746        my($id, $genome, @genomes, %sims);
747        my @tmp= $fig->sims($fid,$max_sims,$max_eval,$db_filter,$max_expand,$sim_filters);
748        @tmp = grep { !($_->id2 =~ /^fig\|/ and $fig->is_deleted_fid($_->id2)) } @tmp;
749      my ($dataset);      my ($dataset);
750      foreach my $sim (@sims){  
751        if ($group_by_genome){
752          #  Collect all sims from genome with the first occurance of the genome:
753          foreach $sim ( @tmp ){
754            $id = $sim->id2;
755            $genome = ($id =~ /^fig\|(\d+\.\d+)\.peg\.\d+/) ? $1 : $id;
756            if (! defined( $sims{ $genome } ) ) { push @genomes, $genome }
757            push @{ $sims{ $genome } }, $sim;
758          }
759          @tmp = map { @{ $sims{$_} } } @genomes;
760        }
761    
762        my $seen_sims={};
763        foreach my $sim (@tmp){
764          my $hit = $sim->[1];          my $hit = $sim->[1];
765            next if ($seen_sims->{$hit});
766            $seen_sims->{$hit}++;
767            my $percent = $sim->[2];
768          my $evalue = $sim->[10];          my $evalue = $sim->[10];
769          my $from = $sim->[8];          my $qfrom = $sim->[6];
770          my $to = $sim->[9];          my $qto = $sim->[7];
771          $dataset = [ { name => 'class', value => "SIM" },          my $hfrom = $sim->[8];
772                          { name => 'acc' , value => $hit},          my $hto = $sim->[9];
773                          { name => 'type', value => "seq"} ,          my $qlength = $sim->[12];
774                          { name => 'evalue', value => $evalue },          my $hlength = $sim->[13];
775                          { name => 'start', value => $from},          my $db = get_database($hit);
776                          { name => 'stop' , value => $to}          my $func = $fig->function_of($hit);
777                          ];          my $organism;
778            if ($fig->org_of($hit)){
779                $organism = $fig->org_of($hit);
780            }
781            else{
782                $organism = "Data not available";
783            }
784    
785            $dataset = {'class' => 'SIM',
786                        'query' => $sim->[0],
787                        'acc' => $hit,
788                        'identity' => $percent,
789                        'type' => 'seq',
790                        'evalue' => $evalue,
791                        'qstart' => $qfrom,
792                        'qstop' => $qto,
793                        'hstart' => $hfrom,
794                        'hstop' => $hto,
795                        'database' => $db,
796                        'organism' => $organism,
797                        'function' => $func,
798                        'qlength' => $qlength,
799                        'hlength' => $hlength,
800                        'fig_id' => $fid
801                        };
802    
803      push (@{$datasets_ref} ,$dataset);      push (@{$datasets_ref} ,$dataset);
804      }      }
805  }  }
806    
807    =head3 get_database (internal)
808    This method gets the database association from the sequence id
809    
810    =cut
811    
812    sub get_database{
813        my ($id) = (@_);
814    
815        my ($db);
816        if ($id =~ /^fig\|/)              { $db = "SEED" }
817        elsif ($id =~ /^gi\|/)            { $db = "NCBI" }
818        elsif ($id =~ /^gb\|/)            { $db = "GenBank" }
819        elsif ($id =~ /^^[NXYZA]P_/)      { $db = "RefSeq" }
820        elsif ($id =~ /^ref\|/)           { $db = "RefSeq" }
821        elsif ($id =~ /^sp\|/)            { $db = "SwissProt" }
822        elsif ($id =~ /^uni\|/)           { $db = "UniProt" }
823        elsif ($id =~ /^tigr\|/)          { $db = "TIGR" }
824        elsif ($id =~ /^pir\|/)           { $db = "PIR" }
825        elsif (($id =~ /^kegg\|/) || ($id =~ /Spy/))    { $db = "KEGG" }
826        elsif ($id =~ /^tr\|/)                          { $db = "TrEMBL" }
827        elsif ($id =~ /^eric\|/)          { $db = "ASAP" }
828        elsif ($id =~ /^img\|/)           { $db = "JGI" }
829        elsif ($id =~ /^pdb\|/)           { $db = "PDB" }
830        elsif ($id =~ /^img\|/)           { $db = "IMG" }
831        elsif ($id =~ /^cmr\|/)           { $db = "CMR" }
832        elsif ($id =~ /^dbj\|/)           { $db = "DBJ" }
833    
834        return ($db);
835    
836    }
837    
838    
839  =head3 get_identical_proteins() (internal)  =head3 get_identical_proteins() (internal)
840    
841  This methods retrieves sims fills the internal data structures.  This methods retrieves sims fills the internal data structures.
# Line 578  Line 844 
844    
845  sub get_identical_proteins{  sub get_identical_proteins{
846    
847      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref,$fig) = (@_);
848      my $fig = new FIG;      #my $fig = new FIG;
849      my @funcs = ();      my $funcs_ref;
850    
851      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);
   
852      foreach my $id (@maps_to) {      foreach my $id (@maps_to) {
853          my ($tmp, $who);          my ($tmp, $who);
854          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {
855              if ($id =~ /^fig\|/)           { $who = "FIG" }              $who = &get_database($id);
856              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]);  
857          }          }
858      }      }
859    
860      my ($dataset);      my $dataset = {'class' => 'IDENTICAL',
861      foreach my $row (@funcs){                     'type' => 'seq',
862          my $id = $row->[0];                     'fig_id' => $fid,
863          my $organism = $fig->org_of($fid);                     'rows' => $funcs_ref
864          my $who = $row->[1];                     };
865          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}  
                      ];  
866          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
867      }  
868    
869  }  }
870    
# Line 627  Line 876 
876    
877  sub get_functional_coupling{  sub get_functional_coupling{
878    
879      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref,$fig) = (@_);
880      my $fig = new FIG;      #my $fig = new FIG;
881      my @funcs = ();      my @funcs = ();
882    
883      # initialize some variables      # initialize some variables
# Line 638  Line 887 
887      my ($bound,$sim_cutoff,$coupling_cutoff) = (5000, 1.0e-10, 4);      my ($bound,$sim_cutoff,$coupling_cutoff) = (5000, 1.0e-10, 4);
888    
889      # get the fc data      # get the fc data
890      my @fc_data = $fig->coupling_and_evidence($fid,$bound,$sim_cutoff,$coupling_cutoff,1);      my @fc_data = $fig->coupling_and_evidence($fid,$bound,$sim_cutoff,$coupling_cutoff);
891    
892      # retrieve data      # retrieve data
893      my @rows = map { ($sc,$neigh) = @$_;      my @rows = map { ($sc,$neigh) = @$_;
894                       [$sc,$neigh,scalar $fig->function_of($neigh)]                       [$sc,$neigh,scalar $fig->function_of($neigh)]
895                    } @fc_data;                    } @fc_data;
896    
897      my ($dataset);      my $dataset = {'class' => 'PCH',
898      foreach my $row (@rows){                     'type' => 'fc',
899          my $id = $row->[1];                     'fig_id' => $fid,
900          my $score = $row->[0];                     'rows' => \@rows
901          my $description = $row->[2];                     };
         $dataset = [ { name => 'class', value => "FC" },  
                      { name => 'score' , value => $score},  
                      { name => 'id', value => "$id"} ,  
                      { name => 'description' , value => $description}  
                      ];  
         push (@{$datasets_ref} ,$dataset);  
     }  
 }  
   
 =head3 get_sims_and_bbhs() (internal)  
   
 This methods retrieves sims and also BBHs and fills the internal data structures.  
   
 =cut  
   
 #     sub get_sims_and_bbhs{  
   
 #       # blast m8 output format  
 #       # id1, id2, %ident, align len, mismatches, gaps, q.start, q.stop, s. start, s.stop, eval, bit  
   
 #       my $Sims=();  
 #       @sims_src = $fig->sims($fid,80,500,"fig",0);  
 #       print "found $#sims_src SIMs\n";  
 #       foreach $sims (@sims_src) {  
 #           my ($sims_string) = "@$sims";  
 # #       print "$sims_string\n";  
 #           my ($rfid,$start,$stop,$eval) = ( $sims_string =~ /\S+\s+(\S+)\s+\S+\s\S+\s+(\S+)\s+(\S+)\s+  
 #                                             \S+\s+\S+\s+\S+\s+\S+\s+(\S+)+.*/);  
 # #       print "ID: $rfid, E:$eval, Start:$start stop:$stop\n";  
 #           $Sims{$rfid}{'eval'}=$eval;  
 #           $Sims{$rfid}{'start'}=$start;  
 #           $Sims{$rfid}{'stop'}=$stop;  
 #           print "$rfid $Sims{$rfid}{'eval'}\n";  
 #       }  
   
 #       # BBHs  
 #       my $BBHs=();  
   
 #       @bbhs_src = $fig->bbhs($fid,1.0e-10);  
 #       print "found $#bbhs_src BBHs\n";  
 #       foreach $bbh (@bbhs_src) {  
 #           #print "@$bbh\n";  
 #           my ($bbh_string) = "@$bbh";  
 #           my ($rfid,$eval,$score) = ( $bbh_string =~ /(\S+)\s(\S+)\s(\S+)/);  
 #           #print "ID: $rfid, E:$eval, S:$score\n";  
 #           $BBHs{$rfid}{'eval'}=$eval;  
 #           $BBHs{$rfid}{'score'}=$score;  
 # #print "$rfid $BBHs{$rfid}{'eval'}\n";  
 #       }  
   
 #     }  
902    
903        push (@{$datasets_ref} ,$dataset);
904    
905    }
906    
907  =head3 new (internal)  =head3 new (internal)
908    
# Line 713  Line 913 
913  sub new {  sub new {
914    my ($class,$dataset) = @_;    my ($class,$dataset) = @_;
915    
   
   #$self = { acc => '',  
 #           description => '',  
 #           class => '',  
 #           type => '',  
 #           start => '',  
 #           stop => '',  
 #           evalue => '',  
 #           score => '',  
 #           display_method => '',  
 #           feature_id => '',  
 #           rank => '',  
 #           supports_annotation => '',  
 #           id => '',  
 #            organism => '',  
 #            who => ''  
 #         };  
   
916    my $self = { class => $dataset->{'class'},    my $self = { class => $dataset->{'class'},
917                 type => $dataset->{'type'}                 type => $dataset->{'type'},
918                   fig_id => $dataset->{'fig_id'},
919                   score => $dataset->{'score'},
920              };              };
921    
922    bless($self,$class);    bless($self,$class);
# Line 740  Line 924 
924    return $self;    return $self;
925  }  }
926    
927  =head3 feature_id (internal)  =head3 identity (internal)
928    
929    Returns the % identity of the similar sequence
930    
931  =cut  =cut
932    
933  sub feature_id {  sub identity {
934    my ($self) = @_;    my ($self) = @_;
935    
936    return $self->{feature_id};      return $self->{identity};
937  }  }
938    
939  =head3 id (internal)  =head3 fig_id (internal)
   
 Returns the ID  of the identical sequence  
940    
941  =cut  =cut
942    
943  sub id {  sub fig_id {
944      my ($self) = @_;
945      return $self->{fig_id};
946    }
947    
948    =head3 feature_id (internal)
949    
950    
951    =cut
952    
953    sub feature_id {
954      my ($self) = @_;
955    
956      return $self->{feature_id};
957    }
958    
959    =head3 id (internal)
960    
961    Returns the ID  of the identical sequence
962    
963    =cut
964    
965    sub id {
966      my ($self) = @_;      my ($self) = @_;
967    
968      return $self->{id};      return $self->{id};
# Line 775  Line 980 
980      return $self->{organism};      return $self->{organism};
981  }  }
982    
983    =head3 function (internal)
984    
985    Returns the function of the identical sequence
986    
987    =cut
988    
989    sub function {
990        my ($self) = @_;
991    
992        return $self->{function};
993    }
994    
995  =head3 database (internal)  =head3 database (internal)
996    
997  Returns the database of the identical sequence  Returns the database of the identical sequence
# Line 787  Line 1004 
1004      return $self->{database};      return $self->{database};
1005  }  }
1006    
1007  #package Observation::Identical;  ############################################################
1008  #1;  ############################################################
1009  #  package Observation::PDB;
1010  #our @ISA = qw(Observation);  # inherits all the methods from Observation  
1011    use base qw(Observation);
1012    
1013    sub new {
1014    
1015        my ($class,$dataset) = @_;
1016        my $self = $class->SUPER::new($dataset);
1017        $self->{acc} = $dataset->{'acc'};
1018        $self->{evalue} = $dataset->{'evalue'};
1019        $self->{start} = $dataset->{'start'};
1020        $self->{stop} = $dataset->{'stop'};
1021        bless($self,$class);
1022        return $self;
1023    }
1024    
1025    =head3 display()
1026    
1027    displays data stored in best_PDB attribute and in Ontology server for given PDB id
1028    
1029    =cut
1030    
1031    sub display{
1032        my ($self,$gd,$fig) = @_;
1033    
1034        my $fid = $self->fig_id;
1035        my $dbmaster = DBMaster->new(-database =>'Ontology',
1036                                     -host     => $WebConfig::DBHOST,
1037                                     -user     => $WebConfig::DBUSER,
1038                                     -password => $WebConfig::DBPWD);
1039    
1040        my $acc = $self->acc;
1041    
1042        my ($pdb_description,$pdb_source,$pdb_ligand);
1043        my $pdb_objs = $dbmaster->pdb->get_objects( { 'id' => $acc } );
1044        if(!scalar(@$pdb_objs)){
1045            $pdb_description = "not available";
1046            $pdb_source = "not available";
1047            $pdb_ligand = "not available";
1048        }
1049        else{
1050            my $pdb_obj = $pdb_objs->[0];
1051            $pdb_description = $pdb_obj->description;
1052            $pdb_source = $pdb_obj->source;
1053            $pdb_ligand = $pdb_obj->ligand;
1054        }
1055    
1056        my $lines = [];
1057        my $line_data = [];
1058        my $line_config = { 'title' => "PDB hit for $fid",
1059                            'hover_title' => 'PDB',
1060                            'short_title' => "best PDB",
1061                            'basepair_offset' => '1' };
1062    
1063        #my $fig = new FIG;
1064        my $seq = $fig->get_translation($fid);
1065        my $fid_stop = length($seq);
1066    
1067        my $fid_element_hash = {
1068            "title" => $fid,
1069            "start" => '1',
1070            "end" =>  $fid_stop,
1071            "color"=> '1',
1072            "zlayer" => '1'
1073            };
1074    
1075        push(@$line_data,$fid_element_hash);
1076    
1077        my $links_list = [];
1078        my $descriptions = [];
1079    
1080  =head3 display_identical()      my $name;
1081        $name = {"title" => 'id',
1082                 "value" => $acc};
1083        push(@$descriptions,$name);
1084    
1085        my $description;
1086        $description = {"title" => 'pdb description',
1087                        "value" => $pdb_description};
1088        push(@$descriptions,$description);
1089    
1090        my $score;
1091        $score = {"title" => "score",
1092                  "value" => $self->evalue};
1093        push(@$descriptions,$score);
1094    
1095        my $start_stop;
1096        my $start_stop_value = $self->start."_".$self->stop;
1097        $start_stop = {"title" => "start-stop",
1098                       "value" => $start_stop_value};
1099        push(@$descriptions,$start_stop);
1100    
1101        my $source;
1102        $source = {"title" => "source",
1103                  "value" => $pdb_source};
1104        push(@$descriptions,$source);
1105    
1106        my $ligand;
1107        $ligand = {"title" => "pdb ligand",
1108                   "value" => $pdb_ligand};
1109        push(@$descriptions,$ligand);
1110    
1111        my $link;
1112        my $link_url ="http://www.rcsb.org/pdb/explore/explore.do?structureId=".$acc;
1113    
1114        $link = {"link_title" => $acc,
1115                 "link" => $link_url};
1116        push(@$links_list,$link);
1117    
1118        my $pdb_element_hash = {
1119            "title" => "PDB homology",
1120            "start" => $self->start,
1121            "end" =>  $self->stop,
1122            "color"=> '6',
1123            "zlayer" => '3',
1124            "links_list" => $links_list,
1125            "description" => $descriptions};
1126    
1127        push(@$line_data,$pdb_element_hash);
1128        $gd->add_line($line_data, $line_config);
1129    
1130        return $gd;
1131    }
1132    
1133    1;
1134    
1135    ############################################################
1136    ############################################################
1137    package Observation::Identical;
1138    
1139    use base qw(Observation);
1140    
1141    sub new {
1142    
1143        my ($class,$dataset) = @_;
1144        my $self = $class->SUPER::new($dataset);
1145        $self->{rows} = $dataset->{'rows'};
1146    
1147        bless($self,$class);
1148        return $self;
1149    }
1150    
1151    =head3 display_table()
1152    
1153  If available use the function specified here to display the "raw" observation.  If available use the function specified here to display the "raw" observation.
1154  This code will display a table for the identical protein  This code will display a table for the identical protein
1155    
1156    
1157  B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evidence.  B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evi
1158    dence.
1159    
1160  =cut  =cut
1161    
 sub display_identical {  
     my ($self, $fid, $cgi) = @_;  
1162    
1163      my $content;  sub display_table{
1164      my $array=Observation->get_objects($fid);      my ($self,$fig) = @_;
1165    
1166        #my $fig = new FIG;
1167        my $fid = $self->fig_id;
1168        my $rows = $self->rows;
1169        my $cgi = new CGI;
1170      my $all_domains = [];      my $all_domains = [];
1171      my $count_identical = 0;      my $count_identical = 0;
1172      foreach my $thing (@$array) {      my $content;
1173          next if ($thing->class ne "IDENTICAL");      foreach my $row (@$rows) {
1174            my $id = $row->[0];
1175            my $who = $row->[1];
1176            my $assignment = $row->[2];
1177            my $organism = "Data not available";
1178            if ($fig->org_of($id)){
1179                $organism = $fig->org_of($id);
1180            }
1181          my $single_domain = [];          my $single_domain = [];
1182          push(@$single_domain,$thing->class);          push(@$single_domain,$who);
1183          my $id = $thing->id;          push(@$single_domain,"<a href='?page=Annotation&feature=$id'>$id</a>");
1184          $count_identical++;          push(@$single_domain,$organism);
1185          push(@$single_domain,&HTML::set_prot_links($cgi,$id));          push(@$single_domain,$assignment);
         push(@$single_domain,$thing->organism);  
         push(@$single_domain,$thing->database);  
         push(@$single_domain,$thing->description);  
1186          push(@$all_domains,$single_domain);          push(@$all_domains,$single_domain);
1187            $count_identical++;
1188      }      }
1189    
1190      if ($count_identical >0){      if ($count_identical >0){
1191          my $table_component = $self->application->component('DomainTable');          $content = $all_domains;
   
         $table_component->columns ([ { 'name' => 'Name', 'filter' => 1 },  
                                      { 'name' => 'ID' },  
                                      { 'name' => 'Organism' },  
                                      { 'name' => 'Database' },  
                                      { 'name' => 'Assignment' }  
                                      ]);  
         $table_component->data($all_domains);  
         $table_component->show_top_browse(1);  
         $table_component->show_bottom_browse(1);  
         $table_component->items_per_page(50);  
         $table_component->show_select_items_per_page(1);  
         $content .= $table_component->output();  
1192      }      }
1193      else{      else{
1194          $content = "<p>This PEG does not have any essentially identical proteins</p>";          $content = "<p>This PEG does not have any essentially identical proteins</p>";
# Line 845  Line 1196 
1196      return ($content);      return ($content);
1197  }  }
1198    
1199    1;
1200    
1201    #########################################
1202    #########################################
1203    package Observation::FC;
1204    1;
1205    
1206    use base qw(Observation);
1207    
1208    sub new {
1209    
1210        my ($class,$dataset) = @_;
1211        my $self = $class->SUPER::new($dataset);
1212        $self->{rows} = $dataset->{'rows'};
1213    
1214        bless($self,$class);
1215        return $self;
1216    }
1217    
1218    =head3 display_table()
1219    
1220    If available use the function specified here to display the "raw" observation.
1221    This code will display a table for the identical protein
1222    
1223    
1224    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
1225    dence.
1226    
1227    =cut
1228    
1229    sub display_table {
1230    
1231        my ($self,$dataset,$fig) = @_;
1232        my $fid = $self->fig_id;
1233        my $rows = $self->rows;
1234        my $cgi = new CGI;
1235        my $functional_data = [];
1236        my $count = 0;
1237        my $content;
1238    
1239        foreach my $row (@$rows) {
1240            my $single_domain = [];
1241            $count++;
1242    
1243            # construct the score link
1244            my $score = $row->[0];
1245            my $toid = $row->[1];
1246            my $link = $cgi->url(-relative => 1) . "?page=Annotation&feature=$fid";
1247            my $sc_link = "<a href='$link'>$score</a>";
1248    
1249            push(@$single_domain,$sc_link);
1250            push(@$single_domain,$row->[1]);
1251            push(@$single_domain,$row->[2]);
1252            push(@$functional_data,$single_domain);
1253        }
1254    
1255        if ($count >0){
1256            $content = $functional_data;
1257        }
1258        else
1259        {
1260            $content = "<p>This PEG does not have any functional coupling</p>";
1261        }
1262        return ($content);
1263    }
1264    
1265    
1266    #########################################
1267    #########################################
1268  package Observation::Domain;  package Observation::Domain;
1269    
1270  use base qw(Observation);  use base qw(Observation);
# Line 865  Line 1285 
1285  sub display {  sub display {
1286      my ($thing,$gd) = @_;      my ($thing,$gd) = @_;
1287      my $lines = [];      my $lines = [];
1288      my $line_config = { 'title' => $thing->acc,  #    my $line_config = { 'title' => $thing->acc,
1289                          'short_title' => $thing->type,  #                       'short_title' => $thing->type,
1290                          'basepair_offset' => '1' };  #                       'basepair_offset' => '1' };
1291      my $color = "4";      my $color = "4";
1292    
1293      my $line_data = [];      my $line_data = [];
1294      my $links_list = [];      my $links_list = [];
1295      my $descriptions = [];      my $descriptions = [];
1296    
1297      my $description_function;      my $db_and_id = $thing->acc;
1298      $description_function = {"title" => $thing->class,      my ($db,$id) = split("::",$db_and_id);
                              "value" => $thing->acc};  
1299    
1300      push(@$descriptions,$description_function);      my $dbmaster = DBMaster->new(-database =>'Ontology',
1301                                    -host     => $WebConfig::DBHOST,
1302                                    -user     => $WebConfig::DBUSER,
1303                                    -password => $WebConfig::DBPWD);
1304    
1305        my ($name_title,$name_value,$description_title,$description_value);
1306    
1307        if($db =~ /PFAM/){
1308            my $new_id;
1309            if ($id =~ /_/){
1310                ($new_id) = ($id) =~ /(.*?)_/;
1311            }
1312            else{
1313                $new_id = $id;
1314            }
1315    
1316            my $pfam_objs = $dbmaster->pfam->get_objects( { 'id' => $new_id } );
1317            if(!scalar(@$pfam_objs)){
1318                $name_title = "name";
1319                $name_value = "not available";
1320                $description_title = "description";
1321                $description_value = "not available";
1322            }
1323            else{
1324                my $pfam_obj = $pfam_objs->[0];
1325                $name_title = "name";
1326                $name_value = $pfam_obj->term;
1327                #$description_title = "description";
1328                #$description_value = $pfam_obj->description;
1329            }
1330        }
1331    
1332        my $short_title = $thing->acc;
1333        $short_title =~ s/::/ - /ig;
1334        my $new_short_title=$short_title;
1335        if ($short_title =~ /interpro/){
1336            ($new_short_title) = ($short_title) =~ /(.*?)_/;
1337        }
1338        my $line_config = { 'title' => $name_value,
1339                            'hover_title', => 'Domain',
1340                            'short_title' => $new_short_title,
1341                            'basepair_offset' => '1' };
1342    
1343        my $name;
1344        my ($new_id) = ($id) =~ /(.*?)_/;
1345        $name = {"title" => $db,
1346                 "value" => $new_id};
1347        push(@$descriptions,$name);
1348    
1349    #    my $description;
1350    #    $description = {"title" => $description_title,
1351    #                   "value" => $description_value};
1352    #    push(@$descriptions,$description);
1353    
1354      my $score;      my $score;
1355      $score = {"title" => "score",      $score = {"title" => "score",
1356                "value" => $thing->evalue};                "value" => $thing->evalue};
1357      push(@$descriptions,$score);      push(@$descriptions,$score);
1358    
1359        my $location;
1360        $location = {"title" => "location",
1361                     "value" => $thing->start . " - " . $thing->stop};
1362        push(@$descriptions,$location);
1363    
1364      my $link_id;      my $link_id;
1365      if ($thing->acc =~/CDD::(\d+)/){      if ($thing->acc =~/::(.*)/){
1366          $link_id = $1;          $link_id = $1;
1367      }      }
1368    
1369      my $link;      my $link;
1370        my $link_url;
1371    #    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"}
1372        if($thing->class eq "PFAM"){$link_url = "http://pfam.sanger.ac.uk/family?acc=$link_id"}
1373        else{$link_url = "NO_URL"}
1374    
1375      $link = {"link_title" => $thing->acc,      $link = {"link_title" => $thing->acc,
1376               "link" => "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"};               "link" => $link_url};
1377      push(@$links_list,$link);      push(@$links_list,$link);
1378    
1379      my $element_hash = {      my $element_hash = {
1380          "title" => $thing->type,          "title" => $name_value,
1381          "start" => $thing->start,          "start" => $thing->start,
1382          "end" =>  $thing->stop,          "end" =>  $thing->stop,
1383          "color"=> $color,          "color"=> $color,
# Line 911  Line 1392 
1392    
1393  }  }
1394    
1395    sub display_table {
1396        my ($self,$dataset) = @_;
1397        my $cgi = new CGI;
1398        my $data = [];
1399        my $count = 0;
1400        my $content;
1401        my $seen = {};
1402    
1403        foreach my $thing (@$dataset) {
1404            next if ($thing->type !~ /dom/);
1405            my $single_domain = [];
1406            $count++;
1407    
1408            my $db_and_id = $thing->acc;
1409            my ($db,$id) = split("::",$db_and_id);
1410    
1411            my $dbmaster = DBMaster->new(-database =>'Ontology',
1412                                    -host     => $WebConfig::DBHOST,
1413                                    -user     => $WebConfig::DBUSER,
1414                                    -password => $WebConfig::DBPWD);
1415    
1416            my ($name_title,$name_value,$description_title,$description_value);
1417    
1418            my $new_id;
1419            if($db =~ /PFAM/){
1420                if ($id =~ /_/){
1421                    ($new_id) = ($id) =~ /(.*?)_/;
1422                }
1423                else{
1424                    $new_id = $id;
1425                }
1426    
1427                next if ($seen->{$new_id});
1428                $seen->{$new_id}=1;
1429    
1430                my $pfam_objs = $dbmaster->pfam->get_objects( { 'id' => $new_id } );
1431    #           print STDERR "VALUES: " . $pfam_objs . "\n";
1432                if(!scalar(@$pfam_objs)){
1433                    $name_title = "name";
1434                    $name_value = "not available";
1435                    $description_title = "description";
1436                    $description_value = "not available";
1437                }
1438                else{
1439                    my $pfam_obj = $pfam_objs->[0];
1440                    $name_title = "name";
1441                    $name_value = $pfam_obj->term;
1442                    #$description_title = "description";
1443                    #$description_value = $pfam_obj->description;
1444                }
1445            }
1446    
1447            my $location =  $thing->start . " - " . $thing->stop;
1448    
1449            push(@$single_domain,$db);
1450            push(@$single_domain,$new_id);
1451            push(@$single_domain,$name_value);
1452            push(@$single_domain,$location);
1453            push(@$single_domain,$thing->evalue);
1454            push(@$single_domain,$description_value);
1455            push(@$data,$single_domain);
1456        }
1457    
1458        if ($count >0){
1459            $content = $data;
1460        }
1461        else
1462        {
1463            $content = "<p>This PEG does not have any similarities to domains</p>";
1464        }
1465    }
1466    
1467    
1468    #########################################
1469    #########################################
1470    package Observation::Location;
1471    
1472    use base qw(Observation);
1473    
1474    sub new {
1475    
1476        my ($class,$dataset) = @_;
1477        my $self = $class->SUPER::new($dataset);
1478        $self->{cleavage_prob} = $dataset->{'cleavage_prob'};
1479        $self->{cleavage_loc} = $dataset->{'cleavage_loc'};
1480        $self->{signal_peptide_score} = $dataset->{'signal_peptide_score'};
1481        $self->{cello_location} = $dataset->{'cello_location'};
1482        $self->{cello_score} = $dataset->{'cello_score'};
1483        $self->{tmpred_score} = $dataset->{'tmpred_score'};
1484        $self->{tmpred_locations} = $dataset->{'tmpred_locations'};
1485        $self->{phobius_signal_location} = $dataset->{'phobius_signal_location'};
1486        $self->{phobius_tm_locations} = $dataset->{'phobius_tm_locations'};
1487    
1488        bless($self,$class);
1489        return $self;
1490    }
1491    
1492    sub display_cello {
1493        my ($thing) = @_;
1494        my $html;
1495        my $cello_location = $thing->cello_location;
1496        my $cello_score = $thing->cello_score;
1497        if($cello_location){
1498            $html .= "<p><font type=verdana size=-2>Subcellular location  prediction: $cello_location, score: $cello_score</font> </p>";
1499            #$html .= "<p>CELLO score: $cello_score </p>";
1500        }
1501        return ($html);
1502    }
1503    
1504    sub display {
1505        my ($thing,$gd,$fig) = @_;
1506    
1507        my $fid = $thing->fig_id;
1508        #my $fig= new FIG;
1509        my $length = length($fig->get_translation($fid));
1510    
1511        my $cleavage_prob;
1512        if($thing->cleavage_prob){$cleavage_prob = $thing->cleavage_prob;}
1513        my ($cleavage_loc_begin,$cleavage_loc_end) = split("-",$thing->cleavage_loc);
1514        my $signal_peptide_score = $thing->signal_peptide_score;
1515        my $cello_location = $thing->cello_location;
1516        my $cello_score = $thing->cello_score;
1517        my $tmpred_score = $thing->tmpred_score;
1518        my @tmpred_locations = split(",",$thing->tmpred_locations);
1519    
1520        my $phobius_signal_location = $thing->phobius_signal_location;
1521        my @phobius_tm_locations = split(",",$thing->phobius_tm_locations);
1522    
1523        my $lines = [];
1524    
1525        #color is
1526        my $color = "6";
1527    
1528    
1529    
1530    #    if($cello_location){
1531    #       my $cello_descriptions = [];
1532    #       my $line_data =[];
1533    #
1534    #       my $line_config = { 'title' => 'Localization Evidence',
1535    #                           'short_title' => 'CELLO',
1536    #                            'hover_title' => 'Localization',
1537    #                           'basepair_offset' => '1' };
1538    #
1539    #       my $description_cello_location = {"title" => 'Best Cello Location',
1540    #                                         "value" => $cello_location};
1541    #
1542    #       push(@$cello_descriptions,$description_cello_location);
1543    #
1544    #       my $description_cello_score = {"title" => 'Cello Score',
1545    #                                      "value" => $cello_score};
1546    #
1547    #       push(@$cello_descriptions,$description_cello_score);
1548    #
1549    #       my $element_hash = {
1550    #           "title" => "CELLO",
1551    #           "color"=> $color,
1552    #           "start" => "1",
1553    #           "end" =>  $length + 1,
1554    #           "zlayer" => '1',
1555    #           "description" => $cello_descriptions};
1556    #
1557    #       push(@$line_data,$element_hash);
1558    #       $gd->add_line($line_data, $line_config);
1559    #    }
1560    #
1561    #    $color = "2";
1562    #    if($tmpred_score){
1563    #       my $line_data =[];
1564    #       my $line_config = { 'title' => 'Localization Evidence',
1565    #                           'short_title' => 'Transmembrane',
1566    #                           'basepair_offset' => '1' };
1567    #
1568    #       foreach my $tmpred (@tmpred_locations){
1569    #           my $descriptions = [];
1570    #           my ($begin,$end) =split("-",$tmpred);
1571    #           my $description_tmpred_score = {"title" => 'TMPRED score',
1572    #                            "value" => $tmpred_score};
1573    #
1574    #           push(@$descriptions,$description_tmpred_score);
1575    #
1576    #           my $element_hash = {
1577    #           "title" => "transmembrane location",
1578    #           "start" => $begin + 1,
1579    #           "end" =>  $end + 1,
1580    #           "color"=> $color,
1581    #           "zlayer" => '5',
1582    #           "type" => 'box',
1583    #           "description" => $descriptions};
1584    #
1585    #           push(@$line_data,$element_hash);
1586    #
1587    #       }
1588    #       $gd->add_line($line_data, $line_config);
1589    #    }
1590    
1591    
1592        if((scalar(@phobius_tm_locations) > 0) || $phobius_signal_location){
1593            my $line_data =[];
1594            my $line_config = { 'title' => 'Localization Evidence, Transmembrane and Signal Peptide',
1595                                'short_title' => 'TM and SP',
1596                                'hover_title' => 'Localization',
1597                                'basepair_offset' => '1' };
1598    
1599            foreach my $tm_loc (@phobius_tm_locations){
1600                my $descriptions = [];
1601                my $description_phobius_tm_locations = {"title" => 'transmembrane location',
1602                                 "value" => $tm_loc};
1603                push(@$descriptions,$description_phobius_tm_locations);
1604    
1605                my ($begin,$end) =split("-",$tm_loc);
1606    
1607                my $element_hash = {
1608                "title" => "Phobius",
1609                "start" => $begin + 1,
1610                "end" =>  $end + 1,
1611                "color"=> '6',
1612                "zlayer" => '4',
1613                "type" => 'bigbox',
1614                "description" => $descriptions};
1615    
1616                push(@$line_data,$element_hash);
1617    
1618            }
1619    
1620            if($phobius_signal_location){
1621                my $descriptions = [];
1622                my $description_phobius_signal_location = {"title" => 'Phobius Signal Location',
1623                                 "value" => $phobius_signal_location};
1624                push(@$descriptions,$description_phobius_signal_location);
1625    
1626    
1627                my ($begin,$end) =split("-",$phobius_signal_location);
1628                my $element_hash = {
1629                "title" => "phobius signal locations",
1630                "start" => $begin + 1,
1631                "end" =>  $end + 1,
1632                "color"=> '1',
1633                "zlayer" => '5',
1634                "type" => 'box',
1635                "description" => $descriptions};
1636                push(@$line_data,$element_hash);
1637            }
1638    
1639            $gd->add_line($line_data, $line_config);
1640        }
1641    
1642    
1643    #    $color = "1";
1644    #    if($signal_peptide_score){
1645    #       my $line_data = [];
1646    #       my $descriptions = [];
1647    #
1648    #       my $line_config = { 'title' => 'Localization Evidence',
1649    #                           'short_title' => 'SignalP',
1650    #                            'hover_title' => 'Localization',
1651    #                           'basepair_offset' => '1' };
1652    #
1653    #       my $description_signal_peptide_score = {"title" => 'signal peptide score',
1654    #                                               "value" => $signal_peptide_score};
1655    #
1656    #       push(@$descriptions,$description_signal_peptide_score);
1657    #
1658    #       my $description_cleavage_prob = {"title" => 'cleavage site probability',
1659    #                                        "value" => $cleavage_prob};
1660    #
1661    #       push(@$descriptions,$description_cleavage_prob);
1662    #
1663    #       my $element_hash = {
1664    #           "title" => "SignalP",
1665    #           "start" => $cleavage_loc_begin - 2,
1666    #           "end" =>  $cleavage_loc_end + 1,
1667    #           "type" => 'bigbox',
1668    #           "color"=> $color,
1669    #           "zlayer" => '10',
1670    #           "description" => $descriptions};
1671    #
1672    #       push(@$line_data,$element_hash);
1673    #       $gd->add_line($line_data, $line_config);
1674    #    }
1675    
1676    
1677        return ($gd);
1678    
1679    }
1680    
1681    sub cleavage_loc {
1682      my ($self) = @_;
1683    
1684      return $self->{cleavage_loc};
1685    }
1686    
1687    sub cleavage_prob {
1688      my ($self) = @_;
1689    
1690      return $self->{cleavage_prob};
1691    }
1692    
1693    sub signal_peptide_score {
1694      my ($self) = @_;
1695    
1696      return $self->{signal_peptide_score};
1697    }
1698    
1699    sub tmpred_score {
1700      my ($self) = @_;
1701    
1702      return $self->{tmpred_score};
1703    }
1704    
1705    sub tmpred_locations {
1706      my ($self) = @_;
1707    
1708      return $self->{tmpred_locations};
1709    }
1710    
1711    sub cello_location {
1712      my ($self) = @_;
1713    
1714      return $self->{cello_location};
1715    }
1716    
1717    sub cello_score {
1718      my ($self) = @_;
1719    
1720      return $self->{cello_score};
1721    }
1722    
1723    sub phobius_signal_location {
1724      my ($self) = @_;
1725      return $self->{phobius_signal_location};
1726    }
1727    
1728    sub phobius_tm_locations {
1729      my ($self) = @_;
1730      return $self->{phobius_tm_locations};
1731    }
1732    
1733    
1734    
1735    #########################################
1736    #########################################
1737    package Observation::Sims;
1738    
1739    use base qw(Observation);
1740    
1741    sub new {
1742    
1743        my ($class,$dataset) = @_;
1744        my $self = $class->SUPER::new($dataset);
1745        $self->{identity} = $dataset->{'identity'};
1746        $self->{acc} = $dataset->{'acc'};
1747        $self->{query} = $dataset->{'query'};
1748        $self->{evalue} = $dataset->{'evalue'};
1749        $self->{qstart} = $dataset->{'qstart'};
1750        $self->{qstop} = $dataset->{'qstop'};
1751        $self->{hstart} = $dataset->{'hstart'};
1752        $self->{hstop} = $dataset->{'hstop'};
1753        $self->{database} = $dataset->{'database'};
1754        $self->{organism} = $dataset->{'organism'};
1755        $self->{function} = $dataset->{'function'};
1756        $self->{qlength} = $dataset->{'qlength'};
1757        $self->{hlength} = $dataset->{'hlength'};
1758    
1759        bless($self,$class);
1760        return $self;
1761    }
1762    
1763    =head3 display()
1764    
1765    If available use the function specified here to display a graphical observation.
1766    This code will display a graphical view of the similarities using the genome drawer object
1767    
1768    =cut
1769    
1770    sub display {
1771        my ($self,$gd,$thing,$fig,$base_start,$in_subs,$cgi) = @_;
1772    
1773        # declare variables
1774        my $window_size = $gd->window_size;
1775        my $peg = $thing->acc;
1776        my $query_id = $thing->query;
1777        my $organism = $thing->organism;
1778        my $abbrev_name = $fig->abbrev($organism);
1779        if (!$organism){
1780          $organism = $peg;
1781          $abbrev_name = $peg;
1782        }
1783        my $genome = $fig->genome_of($peg);
1784        my ($org_tax) = ($genome) =~ /(.*)\./;
1785        my $function = $thing->function;
1786        my $query_start = $thing->qstart;
1787        my $query_stop = $thing->qstop;
1788        my $hit_start = $thing->hstart;
1789        my $hit_stop = $thing->hstop;
1790        my $ln_query = $thing->qlength;
1791        my $ln_hit = $thing->hlength;
1792    #    my $query_color = match_color($query_start, $query_stop, $ln_query, 1);
1793    #    my $hit_color = match_color($hit_start, $hit_stop, $ln_hit, 1);
1794        my $query_color = match_color($query_start, $query_stop, abs($query_stop-$query_start), 1);
1795        my $hit_color = match_color($hit_start, $hit_stop, abs($query_stop-$query_start), 1);
1796    
1797        my $tax_link = "http://www.ncbi.nlm.nih.gov/Taxonomy/Browser/wwwtax.cgi?id=" . $org_tax;
1798    
1799        # hit sequence title
1800        my $line_config = { 'title' => "$organism [$org_tax]",
1801                            'short_title' => "$abbrev_name",
1802                            'title_link' => '$tax_link',
1803                            'basepair_offset' => '0',
1804                            'no_middle_line' => '1'
1805                            };
1806    
1807        # query sequence title
1808        my $replace_id = $peg;
1809        $replace_id =~ s/\|/_/ig;
1810        my $anchor_name = "anchor_". $replace_id;
1811        my $query_config = { 'title' => "Query",
1812                             'short_title' => "Query",
1813                             'title_link' => "changeSimsLocation('$replace_id', 1)",
1814                             'basepair_offset' => '0',
1815                             'no_middle_line' => '1'
1816                             };
1817        my $line_data = [];
1818        my $query_data = [];
1819    
1820        my $element_hash;
1821        my $hit_links_list = [];
1822        my $hit_descriptions = [];
1823        my $query_descriptions = [];
1824    
1825        # get sequence information
1826        # evidence link
1827        my $evidence_link;
1828        if ($peg =~ /^fig\|/){
1829          $evidence_link = "?page=Annotation&feature=".$peg;
1830        }
1831        else{
1832          my $db = &Observation::get_database($peg);
1833          my ($link_id) = ($peg) =~ /\|(.*)/;
1834          $evidence_link = &HTML::alias_url($link_id, $db);
1835          #print STDERR "LINK: $db    $evidence_link";
1836        }
1837        my $link = {"link_title" => $peg,
1838                    "link" => $evidence_link};
1839        push(@$hit_links_list,$link) if ($evidence_link);
1840    
1841        # subsystem link
1842        my $subs = $in_subs->{$peg} if (defined $in_subs->{$peg});
1843        my @subsystems;
1844        foreach my $array (@$subs){
1845            my $subsystem = $$array[0];
1846            push(@subsystems,$subsystem);
1847            my $link = {"link" => "?page=Subsystems&subsystem=$subsystem",
1848                        "link_title" => $subsystem};
1849            push(@$hit_links_list,$link);
1850        }
1851    
1852        # blast alignment
1853        $link = {"link_title" => "view blast alignment",
1854                 "link" => "$FIG_Config::cgi_url/seedviewer.cgi?page=ToolResult&tool=bl2seq&peg1=$query_id&peg2=$peg"};
1855        push (@$hit_links_list,$link) if ($peg =~ /^fig\|/);
1856    
1857        # description data
1858        my $description_function;
1859        $description_function = {"title" => "function",
1860                                 "value" => $function};
1861        push(@$hit_descriptions,$description_function);
1862    
1863        # subsystem description
1864        my $ss_string = join (",", @subsystems);
1865        $ss_string =~ s/_/ /ig;
1866        my $description_ss = {"title" => "subsystems",
1867                              "value" => $ss_string};
1868        push(@$hit_descriptions,$description_ss);
1869    
1870        # location description
1871        # hit
1872        my $description_loc;
1873        $description_loc = {"title" => "Hit Location",
1874                            "value" => $hit_start . " - " . $hit_stop};
1875        push(@$hit_descriptions, $description_loc);
1876    
1877        $description_loc = {"title" => "Sequence Length",
1878                            "value" => $ln_hit};
1879        push(@$hit_descriptions, $description_loc);
1880    
1881        # query
1882        $description_loc = {"title" => "Hit Location",
1883                            "value" => $query_start . " - " . $query_stop};
1884        push(@$query_descriptions, $description_loc);
1885    
1886        $description_loc = {"title" => "Sequence Length",
1887                            "value" => $ln_query};
1888        push(@$query_descriptions, $description_loc);
1889    
1890    
1891    
1892        # evalue score description
1893        my $evalue = $thing->evalue;
1894        while ($evalue =~ /-0/)
1895        {
1896            my ($chunk1, $chunk2) = split(/-/, $evalue);
1897            $chunk2 = substr($chunk2,1);
1898            $evalue = $chunk1 . "-" . $chunk2;
1899        }
1900    
1901        my $color = &color($evalue);
1902        my $description_eval = {"title" => "E-Value",
1903                                "value" => $evalue};
1904        push(@$hit_descriptions, $description_eval);
1905        push(@$query_descriptions, $description_eval);
1906    
1907        my $identity = $self->identity;
1908        my $description_identity = {"title" => "Identity",
1909                                    "value" => $identity};
1910        push(@$hit_descriptions, $description_identity);
1911        push(@$query_descriptions, $description_identity);
1912    
1913    
1914        my $number = $base_start + ($query_start-$hit_start);
1915        #print STDERR "START: $number";
1916        $element_hash = {
1917            "title" => $query_id,
1918            "start" => $base_start,
1919            "end" => $base_start+$ln_query,
1920            "type"=> 'box',
1921            "color"=> $color,
1922            "zlayer" => "2",
1923            "links_list" => $query_links_list,
1924            "description" => $query_descriptions
1925            };
1926        push(@$query_data,$element_hash);
1927    
1928        $element_hash = {
1929            "title" => $query_id . ': HIT AREA',
1930            "start" => $base_start + $query_start,
1931            "end" =>  $base_start + $query_stop,
1932            "type"=> 'smallbox',
1933            "color"=> $query_color,
1934            "zlayer" => "3",
1935            "links_list" => $query_links_list,
1936            "description" => $query_descriptions
1937            };
1938        push(@$query_data,$element_hash);
1939    
1940        $gd->add_line($query_data, $query_config);
1941    
1942    
1943        $element_hash = {
1944                    "title" => $peg,
1945                    "start" => $base_start + ($query_start-$hit_start),
1946                    "end" => $base_start + (($query_start-$hit_start)+$ln_hit),
1947                    "type"=> 'box',
1948                    "color"=> $color,
1949                    "zlayer" => "2",
1950                    "links_list" => $hit_links_list,
1951                    "description" => $hit_descriptions
1952                    };
1953        push(@$line_data,$element_hash);
1954    
1955        $element_hash = {
1956            "title" => $peg . ': HIT AREA',
1957            "start" => $base_start + $query_start,
1958            "end" =>  $base_start + $query_stop,
1959            "type"=> 'smallbox',
1960            "color"=> $hit_color,
1961            "zlayer" => "3",
1962            "links_list" => $hit_links_list,
1963            "description" => $hit_descriptions
1964            };
1965        push(@$line_data,$element_hash);
1966    
1967        $gd->add_line($line_data, $line_config);
1968    
1969        my $breaker = [];
1970        my $breaker_hash = {};
1971        my $breaker_config = { 'no_middle_line' => "1" };
1972    
1973        push (@$breaker, $breaker_hash);
1974        $gd->add_line($breaker, $breaker_config);
1975    
1976        return ($gd);
1977    }
1978    
1979    =head3 display_domain_composition()
1980    
1981    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
1982    
1983    =cut
1984    
1985    sub display_domain_composition {
1986        my ($self,$gd,$fig) = @_;
1987    
1988        #$fig = new FIG;
1989        my $peg = $self->acc;
1990    
1991        my $line_data = [];
1992        my $links_list = [];
1993        my $descriptions = [];
1994    
1995        my @domain_query_results =$fig->get_attributes($peg,"CDD");
1996        #my @domain_query_results = ();
1997        foreach $dqr (@domain_query_results){
1998            my $key = @$dqr[1];
1999            my @parts = split("::",$key);
2000            my $db = $parts[0];
2001            my $id = $parts[1];
2002            my $val = @$dqr[2];
2003            my $from;
2004            my $to;
2005            my $evalue;
2006    
2007            if($val =~/^(\d+\.\d+|0\.0);(\d+)-(\d+)/){
2008                my $raw_evalue = $1;
2009                $from = $2;
2010                $to = $3;
2011                if($raw_evalue =~/(\d+)\.(\d+)/){
2012                    my $part2 = 1000 - $1;
2013                    my $part1 = $2/100;
2014                    $evalue = $part1."e-".$part2;
2015                }
2016                else{
2017                    $evalue = "0.0";
2018                }
2019            }
2020    
2021            my $dbmaster = DBMaster->new(-database =>'Ontology',
2022                                    -host     => $WebConfig::DBHOST,
2023                                    -user     => $WebConfig::DBUSER,
2024                                    -password => $WebConfig::DBPWD);
2025            my ($name_value,$description_value);
2026    
2027            if($db eq "CDD"){
2028                my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
2029                if(!scalar(@$cdd_objs)){
2030                    $name_title = "name";
2031                    $name_value = "not available";
2032                    $description_title = "description";
2033                    $description_value = "not available";
2034                }
2035                else{
2036                    my $cdd_obj = $cdd_objs->[0];
2037                    $name_value = $cdd_obj->term;
2038                    $description_value = $cdd_obj->description;
2039                }
2040            }
2041    
2042            my $domain_name;
2043            $domain_name = {"title" => "name",
2044                            "value" => $name_value};
2045            push(@$descriptions,$domain_name);
2046    
2047            my $description;
2048            $description = {"title" => "description",
2049                            "value" => $description_value};
2050            push(@$descriptions,$description);
2051    
2052            my $score;
2053            $score = {"title" => "score",
2054                      "value" => $evalue};
2055            push(@$descriptions,$score);
2056    
2057            my $link_id = $id;
2058            my $link;
2059            my $link_url;
2060            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"}
2061            elsif($db eq "PFAM"){$link_url = "http://pfam.sanger.ac.uk/family?acc=$link_id"}
2062            else{$link_url = "NO_URL"}
2063    
2064            $link = {"link_title" => $name_value,
2065                     "link" => $link_url};
2066            push(@$links_list,$link);
2067    
2068            my $domain_element_hash = {
2069                "title" => $peg,
2070                "start" => $from,
2071                "end" =>  $to,
2072                "type"=> 'box',
2073                "zlayer" => '4',
2074                "links_list" => $links_list,
2075                "description" => $descriptions
2076                };
2077    
2078            push(@$line_data,$domain_element_hash);
2079    
2080            #just one CDD domain for now, later will add option for multiple domains from selected DB
2081            last;
2082        }
2083    
2084        my $line_config = { 'title' => $peg,
2085                            'hover_title' => 'Domain',
2086                            'short_title' => $peg,
2087                            'basepair_offset' => '1' };
2088    
2089        $gd->add_line($line_data, $line_config);
2090    
2091        return ($gd);
2092    
2093    }
2094    
2095    =head3 display_table()
2096    
2097    If available use the function specified here to display the "raw" observation.
2098    This code will display a table for the similarities protein
2099    
2100    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.
2101    
2102    =cut
2103    
2104    sub display_table {
2105        my ($self,$dataset, $show_columns, $query_fid, $fig, $application, $cgi) = @_;
2106        my ($count, $data, $content, %box_column, $subsystems_column, $evidence_column, %e_identical, $function_color, @ids);
2107    
2108        my $scroll_list;
2109        foreach my $col (@$show_columns){
2110            push (@$scroll_list, $col->{key});
2111        }
2112    
2113        push (@ids, $query_fid);
2114        foreach my $thing (@$dataset) {
2115            next if ($thing->class ne "SIM");
2116            push (@ids, $thing->acc);
2117        }
2118    
2119        $lineages = $fig->taxonomy_list() if (grep /lineage/, @$scroll_list);
2120        my @attributes = $fig->get_attributes(\@ids) if ( (grep /evidence/, @$scroll_list) || (grep /(pfam|mw)/, @$scroll_list) );
2121    
2122        # get the column for the subsystems
2123        $subsystems_column = &get_subsystems_column(\@ids,$fig,$cgi,'hash');
2124    
2125        # get the column for the evidence codes
2126        $evidence_column = &get_evidence_column(\@ids, \@attributes, $fig, $cgi, 'hash');
2127    
2128        # get the column for pfam_domain
2129        $pfam_column = &get_attrb_column(\@ids, \@attributes, $fig, $cgi, 'pfam', 'PFAM', 'hash') if (grep /^pfam$/, @$scroll_list);
2130    
2131        # get the column for molecular weight
2132        $mw_column = &get_attrb_column(\@ids, \@attributes, $fig, $cgi, 'mw', 'molecular_weight', 'hash') if (grep /^mw$/, @$scroll_list);
2133    
2134        # get the column for organism's habitat
2135        my $habitat_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'habitat', 'Habitat', 'hash') if (grep /^habitat$/, @$scroll_list);
2136    
2137        # get the column for organism's temperature optimum
2138        my $temperature_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'temperature', 'Optimal_Temperature', 'hash') if (grep /^temperature$/, @$scroll_list);
2139    
2140        # get the column for organism's temperature range
2141        my $temperature_range_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'temp_range', 'Temperature_Range', 'hash') if (grep /^temp_range$/, @$scroll_list);
2142    
2143        # get the column for organism's oxygen requirement
2144        my $oxygen_req_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'oxygen', 'Oxygen_Requirement', 'hash') if (grep /^oxygen$/, @$scroll_list);
2145    
2146        # get the column for organism's pathogenicity
2147        my $pathogenic_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'pathogenic', 'Pathogenic', 'hash') if (grep /^pathogenic$/, @$scroll_list);
2148    
2149        # get the column for organism's pathogenicity host
2150        my $pathogenic_in_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'pathogenic_in', 'Pathogenic_In', 'hash') if (grep /^pathogenic_in$/, @$scroll_list);
2151    
2152        # get the column for organism's salinity
2153        my $salinity_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'salinity', 'Salinity', 'hash') if (grep /^salinity$/, @$scroll_list);
2154    
2155        # get the column for organism's motility
2156        my $motility_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'motility', 'Motility', 'hash') if (grep /^motility$/, @$scroll_list);
2157    
2158        # get the column for organism's gram stain
2159        my $gram_stain_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'gram_stain', 'Gram_Stain', 'hash') if (grep /^gram_stain$/, @$scroll_list);
2160    
2161        # get the column for organism's endospores
2162        my $endospores_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'endospores', 'Endospores', 'hash') if (grep /^endospores$/, @$scroll_list);
2163    
2164        # get the column for organism's shape
2165        my $shape_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'shape', 'Shape', 'hash') if (grep /^shape$/, @$scroll_list);
2166    
2167        # get the column for organism's disease
2168        my $disease_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'disease', 'Disease', 'hash') if (grep /^disease$/, @$scroll_list);
2169    
2170        # get the column for organism's disease
2171        my $gc_content_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'gc_content', 'GC_Content', 'hash') if (grep /^gc_content$/, @$scroll_list);
2172    
2173        # get the column for transmembrane domains
2174        my $transmembrane_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'transmembrane', 'Phobius::transmembrane', 'hash') if (grep /^transmembrane$/, @$scroll_list);
2175    
2176        # get the column for similar to human
2177        my $similar_to_human_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'similar_to_human', 'similar_to_human', 'hash') if (grep /^similar_to_human$/, @$scroll_list);
2178    
2179        # get the column for signal peptide
2180        my $signal_peptide_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'signal_peptide', 'Phobius::signal', 'hash') if (grep /^signal_peptide$/, @$scroll_list);
2181    
2182        # get the column for transmembrane domains
2183        my $isoelectric_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'isoelectric', 'isoelectric_point', 'hash') if (grep /^isoelectric$/, @$scroll_list);
2184    
2185        # get the column for conserved neighborhood
2186        my $cons_neigh_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'conserved_neighborhood', undef, 'hash') if (grep /^conserved_neighborhood$/, @$scroll_list);
2187    
2188        # get the column for cellular location
2189        my $cell_location_column = &get_attrb_column(\@ids, undef, $fig, $cgi, 'cellular_location', 'PSORT::', 'hash') if (grep /^isoelectric$/, @$scroll_list);
2190    
2191        # get the aliases
2192        my $alias_col;
2193        if ( (grep /asap_id/, @$scroll_list) || (grep /ncbi_id/, @$scroll_list) ||
2194             (grep /refseq_id/, @$scroll_list) || (grep /swissprot_id/, @$scroll_list) ||
2195             (grep /uniprot_id/, @$scroll_list) || (grep /tigr_id/, @$scroll_list) ||
2196             (grep /kegg_id/, @$scroll_list) || (grep /pir_id/, @$scroll_list) ||
2197             (grep /trembl_id/, @$scroll_list) || (grep /jgi_id/, @$scroll_list) ) {
2198            $alias_col = &get_db_aliases(\@ids,$fig,'all',$cgi,'hash');
2199        }
2200    
2201        # get the colors for the function cell
2202        my $functions = $fig->function_of_bulk(\@ids,1);
2203        $functional_color = &get_function_color_cell($functions, $fig);
2204        my $query_function = $fig->function_of($query_fid);
2205    
2206        my %e_identical = &get_essentially_identical($query_fid,$dataset,$fig);
2207    
2208        my $figfam_data = &FIG::get_figfams_data();
2209        my $figfams = new FFs($figfam_data);
2210        my $same_genome_flag = 0;
2211    
2212        my $func_color_offset=0;
2213        unshift(@$dataset, $query_fid);
2214        for (my $thing_count=0;$thing_count<scalar @$dataset;$thing_count++){
2215    #    foreach my $thing ( @$dataset){
2216            my $thing = $dataset->[$thing_count];
2217            my $next_thing = $dataset->[$thing_count+1] if (defined $dataset->[$thing_count+1]);
2218            my ($id, $taxid, $iden, $ln1,$ln2,$b1,$b2,$e1,$e2,$d1,$d2,$color1,$color2,$reg1,$reg2, $next_org);
2219            if ($thing eq $query_fid){
2220                $id = $thing;
2221                $taxid   = $fig->genome_of($id);
2222                $organism = $fig->genus_species($taxid);
2223                $current_function = $fig->function_of($id);
2224            }
2225            else{
2226                next if ($thing->class ne "SIM");
2227    
2228                $id      = $thing->acc;
2229                $evalue  = $thing->evalue;
2230                $taxid   = $fig->genome_of($id);
2231                $iden    = $thing->identity;
2232                $organism= $thing->organism;
2233                $ln1     = $thing->qlength;
2234                $ln2     = $thing->hlength;
2235                $b1      = $thing->qstart;
2236                $e1      = $thing->qstop;
2237                $b2      = $thing->hstart;
2238                $e2      = $thing->hstop;
2239                $d1      = abs($e1 - $b1) + 1;
2240                $d2      = abs($e2 - $b2) + 1;
2241                $color1  = match_color( $b1, $e1, $ln1 );
2242                $color2  = match_color( $b2, $e2, $ln2 );
2243                $reg1    = {'data'=> "$b1-$e1 (<b>$d1/$ln1</b>)", 'highlight' => $color1};
2244                $reg2    = {'data'=> "$b2-$e2 (<b>$d2/$ln2</b>)", 'highlight' => $color2};
2245                $current_function = $thing->function;
2246                $next_org = $next_thing->organism if (defined $next_thing);
2247            }
2248    
2249            my $single_domain = [];
2250            $count++;
2251    
2252            # organisms cell
2253            my ($org, $org_color) = $fig->org_and_color_of($id);
2254    
2255            my $org_cell;
2256            if ( ($next_org ne $organism) && ($same_genome_flag == 0) ){
2257                $org_cell = { 'data' =>  $organism, 'highlight' => $org_color};
2258            }
2259            elsif ($next_org eq $organism){
2260                $org_cell = { 'data' =>  "<b>" . $organism . "</b>", 'highlight' => $org_color};
2261                $same_genome_flag = 1;
2262            }
2263            elsif ($same_genome_flag == 1){
2264                $org_cell = { 'data' =>  "<b>" . $organism . "</b>", 'highlight' => $org_color};
2265                $same_genome_flag = 0;
2266            }
2267    
2268            # checkbox cell
2269            my ($box_cell,$tax, $radio_cell);
2270            my $field_name = "tables_" . $id;
2271            my $pair_name = "visual_" . $id;
2272            my $cell_name = "cell_". $id;
2273            my $replace_id = $id;
2274            $replace_id =~ s/\|/_/ig;
2275            my $white = '#ffffff';
2276            $white = '#999966' if ($id eq $query_fid);
2277            $org_color = '#999966' if ($id eq $query_fid);
2278            my $anchor_name = "anchor_". $replace_id;
2279            my $checked = "";
2280            #$checked = "checked" if ($id eq $query_fid);
2281            if ($id =~ /^fig\|/){
2282              my $box = qq~<a name="$anchor_name"></a><input type="checkbox" name="seq" value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name','$cell_name');" $checked>~;
2283              $box_cell = { 'data'=>$box, 'highlight'=>$org_color};
2284              $tax = $fig->genome_of($id);
2285            }
2286            else{
2287              my $box = qq(<a name="$anchor_name"></a>);
2288              $box_cell = { 'data'=>$box, 'highlight'=>$org_color};
2289            }
2290    
2291            # create the radio cell for any sequence, not just fig ids
2292            my $radio = qq(<input type="radio" name="function_select" value="$current_function" id="$field_name" onClick="clearText('new_text_function')">);
2293            $radio_cell = { 'data'=>$radio, 'highlight'=>$white};
2294    
2295            # get the linked fig id
2296            my $anchor_link = "graph_" . $replace_id;
2297            my $fig_data =  "<table><tr><td><a href='?page=Annotation&feature=$id'>$id</a></td>" . "&nbsp;" x 2;
2298            $fig_data .= qq(<td><img height='10px' width='20px' src='$FIG_Config::cgi_url/Html/anchor_alignment.png' alt='View Graphic View of Alignment' onClick='changeSimsLocation("$anchor_link", 0)'/></td></tr></table>);
2299            my $fig_col = {'data'=> $fig_data,
2300                           'highlight'=>$white};
2301    
2302            $replace_id = $peg;
2303            $replace_id =~ s/\|/_/ig;
2304            $anchor_name = "anchor_". $replace_id;
2305            my $query_config = { 'title' => "Query",
2306                                 'short_title' => "Query",
2307                                 'title_link' => "changeSimsLocation('$replace_id')",
2308                                 'basepair_offset' => '0'
2309                                 };
2310    
2311            # function cell
2312            my $function_cell_colors = {0=>"#ffffff", 1=>"#eeccaa", 2=>"#ffaaaa",
2313                                        3=>"#ffcc66", 4=>"#ffff00", 5=>"#aaffaa",
2314                                        6=>"#bbbbff", 7=>"#ffaaff", 8=>"#dddddd"};
2315    
2316            my $function_color;
2317            if ( (defined($functional_color->{$query_function})) && ($functional_color->{$query_function} == 1) ){
2318                $function_color = $function_cell_colors->{ $functional_color->{$current_function} - $func_color_offset};
2319            }
2320            else{
2321                $function_color = $function_cell_colors->{ $functional_color->{$current_function}};
2322            }
2323            my $function_cell;
2324            if ($current_function){
2325              if ($current_function eq $query_function){
2326                $function_cell = {'data'=>$current_function, 'highlight'=>$function_cell_colors->{0}};
2327                $func_color_offset=1;
2328              }
2329              else{
2330                  $function_cell = {'data'=>$current_function,'highlight' => $function_color};
2331              }
2332            }
2333            else{
2334              $function_cell = {'data'=>$current_function,'highlight' => "#dddddd"};
2335            }
2336    
2337            if ($id eq $query_fid){
2338                push (@$single_domain, $box_cell, {'data'=>qq~<i>Query Sequence: </i>~  . qq~<b>$id</b>~ , 'highlight'=>$white}, {'data'=> 'n/a', 'highlight'=>$white},
2339                      {'data'=>'n/a', 'highlight'=>$white}, {'data'=>'n/a', 'highlight'=>$white}, {'data'=>'n/a', 'highlight'=>$white},
2340                      {'data' =>  $organism, 'highlight'=> $white}, {'data'=>$current_function, 'highlight'=>$white},
2341                      {'data'=>$subsystems_column->{$id},'highlight'=>$white},
2342                      {'data'=>$evidence_column->{$id},'highlight'=>$white});  # permanent columns
2343            }
2344            else{
2345                push (@$single_domain, $box_cell, $fig_col, {'data'=> $evalue, 'highlight'=>"#ffffff"},
2346                      {'data'=>"$iden\%", 'highlight'=>"#ffffff"}, $reg1, $reg2, $org_cell, $function_cell,
2347                      {'data'=>$subsystems_column->{$id},'highlight'=>"#ffffff"},
2348                      {'data'=>$evidence_column->{$id},'highlight'=>"#ffffff"});  # permanent columns
2349    
2350            }
2351    
2352            if ( ( $application->session->user) ){
2353                my $user = $application->session->user;
2354                if ($user && $user->has_right(undef, 'annotate', 'genome', $fig->genome_of($id))) {
2355                    push (@$single_domain,$radio_cell);
2356                }
2357            }
2358    
2359            my ($ff) = $figfams->families_containing_peg($id);
2360    
2361            foreach my $col (@$scroll_list){
2362                if ($id eq $query_fid) { $highlight_color = "#999966"; }
2363                else { $highlight_color = "#ffffff"; }
2364    
2365                if ($col =~ /pfam/)                       {push(@$single_domain,{'data'=>$pfam_column->{$id},'highlight'=>$highlight_color});}
2366                elsif ($col =~ /mw/)                         {push(@$single_domain,{'data'=>$mw_column->{$id},'highlight'=>$highlight_color});}
2367                elsif ($col =~ /habitat/)                    {push(@$single_domain,{'data'=>$habitat_column->{$id},'highlight'=>$highlight_color});}
2368                elsif ($col =~ /temperature/)                {push(@$single_domain,{'data'=>$temperature_column->{$id},'highlight'=>$highlight_color});}
2369                elsif ($col =~ /temp_range/)                 {push(@$single_domain,{'data'=>$temperature_range_column->{$id},'highlight'=>$highlight_color});}
2370                elsif ($col =~ /oxygen/)                     {push(@$single_domain,{'data'=>$oxygen_req_column->{$id},'highlight'=>$highlight_color});}
2371                elsif ($col =~ /^pathogenic$/)               {push(@$single_domain,{'data'=>$pathogenic_column->{$id},'highlight'=>$highlight_color});}
2372                elsif ($col =~ /^pathogenic_in$/)            {push(@$single_domain,{'data'=>$pathogenic_in_column->{$id},'highlight'=>$highlight_color});}
2373                elsif ($col =~ /salinity/)                   {push(@$single_domain,{'data'=>$salinity_column->{$id},'highlight'=>$highlight_color});}
2374                elsif ($col =~ /motility/)                   {push(@$single_domain,{'data'=>$motility_column->{$id},'highlight'=>$highlight_color});}
2375                elsif ($col =~ /gram_stain/)                 {push(@$single_domain,{'data'=>$gram_stain_column->{$id},'highlight'=>$highlight_color});}
2376                elsif ($col =~ /endospores/)                 {push(@$single_domain,{'data'=>$endospores_column->{$id},'highlight'=>$highlight_color});}
2377                elsif ($col =~ /shape/)                      {push(@$single_domain,{'data'=>$shape_column->{$id},'highlight'=>$highlight_color});}
2378                elsif ($col =~ /disease/)                    {push(@$single_domain,{'data'=>$disease_column->{$id},'highlight'=>$highlight_color});}
2379                elsif ($col =~ /gc_content/)                 {push(@$single_domain,{'data'=>$gc_content_column->{$id},'highlight'=>$highlight_color});}
2380                elsif ($col =~ /transmembrane/)              {push(@$single_domain,{'data'=>$transmembrane_column->{$id},'highlight'=>$highlight_color});}
2381                elsif ($col =~ /signal_peptide/)             {push(@$single_domain,{'data'=>$signal_peptide_column->{$id},'highlight'=>$highlight_color});}
2382                elsif ($col =~ /isoelectric/)                {push(@$single_domain,{'data'=>$isoelectric_column->{$id},'highlight'=>$highlight_color});}
2383                elsif ($col =~ /conerved_neighborhood/)     {push(@$single_domain,{'data'=>$cons_neigh_column->{$id},'highlight'=>$highlight_color});}
2384                elsif ($col =~ /cellular_location/)          {push(@$single_domain,{'data'=>$cell_location_column->{$id},'highlight'=>$highlight_color});}
2385                elsif ($col =~ /ncbi_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"NCBI"},'highlight'=>$highlight_color});}
2386                elsif ($col =~ /refseq_id/)                  {push(@$single_domain,{'data'=>$alias_col->{$id}->{"RefSeq"},'highlight'=>$highlight_color});}
2387                elsif ($col =~ /swissprot_id/)               {push(@$single_domain,{'data'=>$alias_col->{$id}->{"SwissProt"},'highlight'=>$highlight_color});}
2388                elsif ($col =~ /uniprot_id/)                 {push(@$single_domain,{'data'=>$alias_col->{$id}->{"UniProt"},'highlight'=>$highlight_color});}
2389                elsif ($col =~ /tigr_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"TIGR"},'highlight'=>$highlight_color});}
2390                elsif ($col =~ /pir_id/)                     {push(@$single_domain,{'data'=>$alias_col->{$id}->{"PIR"},'highlight'=>$highlight_color});}
2391                elsif ($col =~ /kegg_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"KEGG"},'highlight'=>$highlight_color});}
2392                elsif ($col =~ /trembl_id/)                  {push(@$single_domain,{'data'=>$alias_col->{$id}->{"TrEMBL"},'highlight'=>$highlight_color});}
2393                elsif ($col =~ /asap_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"ASAP"},'highlight'=>$highlight_color});}
2394                elsif ($col =~ /jgi_id/)                     {push(@$single_domain,{'data'=>$alias_col->{$id}->{"JGI"},'highlight'=>$highlight_color});}
2395                elsif ($col =~ /lineage/)                   {push(@$single_domain,{'data'=>$lineages->{$tax},'highlight'=>$highlight_color});}
2396                elsif ($col =~ /figfam/)                     {push(@$single_domain,{'data'=>"<a href='?page=FigFamViewer&figfam=" . $ff . "' target='_new'>" . $ff . "</a>",'highlight'=>$highlight_color});}
2397            }
2398            push(@$data,$single_domain);
2399        }
2400        if ($count >0 ){
2401            $content = $data;
2402        }
2403        else{
2404            $content = "<p>This PEG does not have any similarities</p>";
2405        }
2406        shift(@$dataset);
2407        return ($content);
2408    }
2409    
2410    
2411    =head3 display_figfam_table()
2412    
2413    If available use the function specified here to display the "raw" observation.
2414    This code will display a table for the similarities protein
2415    
2416    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.
2417    
2418    =cut
2419    
2420    sub display_figfam_table {
2421      my ($self,$ids, $show_columns, $fig, $application, $cgi) = @_;
2422      my ($count, $data, $content, %box_column, $subsystems_column, $evidence_column, %e_identical, $function_color, @ids);
2423    
2424      my $scroll_list;
2425      foreach my $col (@$show_columns){
2426        push (@$scroll_list, $col->{key});
2427      }
2428    
2429      $lineages = $fig->taxonomy_list() if (grep /lineage/, @$scroll_list);
2430      my @attributes = $fig->get_attributes($ids) if ( (grep /evidence/, @$scroll_list) || (grep /(pfam|mw)/, @$scroll_list) );
2431    
2432      # get the column for the subsystems
2433      $subsystems_column = &get_subsystems_column($ids,$fig,$cgi,'hash');
2434    
2435      # get the column for the evidence codes
2436      $evidence_column = &get_evidence_column($ids, \@attributes, $fig, $cgi, 'hash') if (grep /^evidence$/, @$scroll_list);
2437    
2438      # get the column for pfam_domain
2439      $pfam_column = &get_attrb_column($ids, \@attributes, $fig, $cgi, 'pfam', 'PFAM', 'hash') if (grep /^pfam$/, @$scroll_list);
2440    
2441      # get the column for molecular weight
2442      $mw_column = &get_attrb_column($ids, \@attributes, $fig, $cgi, 'mw', 'molecular_weight', 'hash') if (grep /^mw$/, @$scroll_list);
2443    
2444      # get the column for organism's habitat
2445      my $habitat_column = &get_attrb_column($ids, undef, $fig, $cgi, 'habitat', 'Habitat', 'hash') if (grep /^habitat$/, @$scroll_list);
2446    
2447      # get the column for organism's temperature optimum
2448      my $temperature_column = &get_attrb_column($ids, undef, $fig, $cgi, 'temperature', 'Optimal_Temperature', 'hash') if (grep /^temperature$/, @$scroll_list);
2449    
2450      # get the column for organism's temperature range
2451      my $temperature_range_column = &get_attrb_column($ids, undef, $fig, $cgi, 'temp_range', 'Temperature_Range', 'hash') if (grep /^temp_range$/, @$scroll_list);
2452    
2453      # get the column for organism's oxygen requirement
2454      my $oxygen_req_column = &get_attrb_column($ids, undef, $fig, $cgi, 'oxygen', 'Oxygen_Requirement', 'hash') if (grep /^oxygen$/, @$scroll_list);
2455    
2456      # get the column for organism's pathogenicity
2457      my $pathogenic_column = &get_attrb_column($ids, undef, $fig, $cgi, 'pathogenic', 'Pathogenic', 'hash') if (grep /^pathogenic$/, @$scroll_list);
2458    
2459      # get the column for organism's pathogenicity host
2460      my $pathogenic_in_column = &get_attrb_column($ids, undef, $fig, $cgi, 'pathogenic_in', 'Pathogenic_In', 'hash') if (grep /^pathogenic_in$/, @$scroll_list);
2461    
2462      # get the column for organism's salinity
2463      my $salinity_column = &get_attrb_column($ids, undef, $fig, $cgi, 'salinity', 'Salinity', 'hash') if (grep /^salinity$/, @$scroll_list);
2464    
2465      # get the column for organism's motility
2466      my $motility_column = &get_attrb_column($ids, undef, $fig, $cgi, 'motility', 'Motility', 'hash') if (grep /^motility$/, @$scroll_list);
2467    
2468      # get the column for organism's gram stain
2469      my $gram_stain_column = &get_attrb_column($ids, undef, $fig, $cgi, 'gram_stain', 'Gram_Stain', 'hash') if (grep /^gram_stain$/, @$scroll_list);
2470    
2471      # get the column for organism's endospores
2472      my $endospores_column = &get_attrb_column($ids, undef, $fig, $cgi, 'endospores', 'Endospores', 'hash') if (grep /^endospores$/, @$scroll_list);
2473    
2474      # get the column for organism's shape
2475      my $shape_column = &get_attrb_column($ids, undef, $fig, $cgi, 'shape', 'Shape', 'hash') if (grep /^shape$/, @$scroll_list);
2476    
2477      # get the column for organism's disease
2478      my $disease_column = &get_attrb_column($ids, undef, $fig, $cgi, 'disease', 'Disease', 'hash') if (grep /^disease$/, @$scroll_list);
2479    
2480      # get the column for organism's disease
2481      my $gc_content_column = &get_attrb_column($ids, undef, $fig, $cgi, 'gc_content', 'GC_Content', 'hash') if (grep /^gc_content$/, @$scroll_list);
2482    
2483      # get the column for transmembrane domains
2484      my $transmembrane_column = &get_attrb_column($ids, undef, $fig, $cgi, 'transmembrane', 'Phobius::transmembrane', 'hash') if (grep /^transmembrane$/, @$scroll_list);
2485    
2486      # get the column for similar to human
2487      my $similar_to_human_column = &get_attrb_column($ids, undef, $fig, $cgi, 'similar_to_human', 'similar_to_human', 'hash') if (grep /^similar_to_human$/, @$scroll_list);
2488    
2489      # get the column for signal peptide
2490      my $signal_peptide_column = &get_attrb_column($ids, undef, $fig, $cgi, 'signal_peptide', 'Phobius::signal', 'hash') if (grep /^signal_peptide$/, @$scroll_list);
2491    
2492      # get the column for transmembrane domains
2493      my $isoelectric_column = &get_attrb_column($ids, undef, $fig, $cgi, 'isoelectric', 'isoelectric_point', 'hash') if (grep /^isoelectric$/, @$scroll_list);
2494    
2495      # get the column for conserved neighborhood
2496      my $cons_neigh_column = &get_attrb_column($ids, undef, $fig, $cgi, 'conserved_neighborhood', undef, 'hash') if (grep /^conserved_neighborhood$/, @$scroll_list);
2497    
2498      # get the column for cellular location
2499      my $cell_location_column = &get_attrb_column($ids, undef, $fig, $cgi, 'cellular_location', 'PSORT::', 'hash') if (grep /^isoelectric$/, @$scroll_list);
2500    
2501      # get the aliases
2502      my $alias_col;
2503      if ( (grep /asap_id/, @$scroll_list) || (grep /ncbi_id/, @$scroll_list) ||
2504           (grep /refseq_id/, @$scroll_list) || (grep /swissprot_id/, @$scroll_list) ||
2505           (grep /uniprot_id/, @$scroll_list) || (grep /tigr_id/, @$scroll_list) ||
2506           (grep /kegg_id/, @$scroll_list) || (grep /pir_id/, @$scroll_list) ||
2507           (grep /trembl_id/, @$scroll_list) || (grep /jgi_id/, @$scroll_list) ) {
2508        $alias_col = &get_db_aliases($ids,$fig,'all',$cgi,'hash');
2509      }
2510    
2511      foreach my $id ( @$ids){
2512        my $current_function = $fig->function_of($id);
2513        my $organism = $fig->org_of($id);
2514        my $single_domain = [];
2515    
2516        # organisms cell
2517        my ($org, $org_color) = $fig->org_and_color_of($id);
2518        my $org_cell = { 'data' =>  $organism, 'highlight' => $org_color};
2519    
2520        # get the linked fig id
2521        my $fig_data =  "<a href='?page=Annotation&feature=$id'>$id</a>";
2522        my $fig_col = {'data'=> $fig_data,
2523                       'highlight'=>"#ffffff"};
2524    
2525        # function cell
2526        $function_cell = {'data'=>$current_function, 'highlight'=> "#ffffff"};
2527    
2528        # insert data
2529        push (@$single_domain, $fig_col, $org_cell, {'data'=>$subsystems_column->{$id},'highlight'=>"#ffffff"}, $function_cell);
2530    
2531        foreach my $col (@$scroll_list){
2532          my $highlight_color = "#ffffff";
2533    
2534          if ($col =~ /evidence/)                   {push(@$single_domain,{'data'=>$evidence_column->{$id},'highlight'=>$highlight_color});}
2535          elsif ($col =~ /pfam/)                       {push(@$single_domain,{'data'=>$pfam_column->{$id},'highlight'=>$highlight_color});}
2536          elsif ($col =~ /mw/)                         {push(@$single_domain,{'data'=>$mw_column->{$id},'highlight'=>$highlight_color});}
2537          elsif ($col =~ /habitat/)                    {push(@$single_domain,{'data'=>$habitat_column->{$id},'highlight'=>$highlight_color});}
2538          elsif ($col =~ /temperature/)                {push(@$single_domain,{'data'=>$temperature_column->{$id},'highlight'=>$highlight_color});}
2539          elsif ($col =~ /temp_range/)                 {push(@$single_domain,{'data'=>$temperature_range_column->{$id},'highlight'=>$highlight_color});}
2540          elsif ($col =~ /oxygen/)                     {push(@$single_domain,{'data'=>$oxygen_req_column->{$id},'highlight'=>$highlight_color});}
2541          elsif ($col =~ /^pathogenic$/)               {push(@$single_domain,{'data'=>$pathogenic_column->{$id},'highlight'=>$highlight_color});}
2542          elsif ($col =~ /^pathogenic_in$/)            {push(@$single_domain,{'data'=>$pathogenic_in_column->{$id},'highlight'=>$highlight_color});}
2543          elsif ($col =~ /salinity/)                   {push(@$single_domain,{'data'=>$salinity_column->{$id},'highlight'=>$highlight_color});}
2544          elsif ($col =~ /motility/)                   {push(@$single_domain,{'data'=>$motility_column->{$id},'highlight'=>$highlight_color});}
2545          elsif ($col =~ /gram_stain/)                 {push(@$single_domain,{'data'=>$gram_stain_column->{$id},'highlight'=>$highlight_color});}
2546          elsif ($col =~ /endospores/)                 {push(@$single_domain,{'data'=>$endospores_column->{$id},'highlight'=>$highlight_color});}
2547          elsif ($col =~ /shape/)                      {push(@$single_domain,{'data'=>$shape_column->{$id},'highlight'=>$highlight_color});}
2548          elsif ($col =~ /disease/)                    {push(@$single_domain,{'data'=>$disease_column->{$id},'highlight'=>$highlight_color});}
2549          elsif ($col =~ /gc_content/)                 {push(@$single_domain,{'data'=>$gc_content_column->{$id},'highlight'=>$highlight_color});}
2550          elsif ($col =~ /transmembrane/)              {push(@$single_domain,{'data'=>$transmembrane_column->{$id},'highlight'=>$highlight_color});}
2551          elsif ($col =~ /signal_peptide/)             {push(@$single_domain,{'data'=>$signal_peptide_column->{$id},'highlight'=>$highlight_color});}
2552          elsif ($col =~ /isoelectric/)                {push(@$single_domain,{'data'=>$isoelectric_column->{$id},'highlight'=>$highlight_color});}
2553          elsif ($col =~ /conerved_neighborhood/)     {push(@$single_domain,{'data'=>$cons_neigh_column->{$id},'highlight'=>$highlight_color});}
2554          elsif ($col =~ /cellular_location/)          {push(@$single_domain,{'data'=>$cell_location_column->{$id},'highlight'=>$highlight_color});}
2555          elsif ($col =~ /ncbi_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"NCBI"},'highlight'=>$highlight_color});}
2556          elsif ($col =~ /refseq_id/)                  {push(@$single_domain,{'data'=>$alias_col->{$id}->{"RefSeq"},'highlight'=>$highlight_color});}
2557          elsif ($col =~ /swissprot_id/)               {push(@$single_domain,{'data'=>$alias_col->{$id}->{"SwissProt"},'highlight'=>$highlight_color});}
2558          elsif ($col =~ /uniprot_id/)                 {push(@$single_domain,{'data'=>$alias_col->{$id}->{"UniProt"},'highlight'=>$highlight_color});}
2559          elsif ($col =~ /tigr_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"TIGR"},'highlight'=>$highlight_color});}
2560          elsif ($col =~ /pir_id/)                     {push(@$single_domain,{'data'=>$alias_col->{$id}->{"PIR"},'highlight'=>$highlight_color});}
2561          elsif ($col =~ /kegg_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"KEGG"},'highlight'=>$highlight_color});}
2562          elsif ($col =~ /trembl_id/)                  {push(@$single_domain,{'data'=>$alias_col->{$id}->{"TrEMBL"},'highlight'=>$highlight_color});}
2563          elsif ($col =~ /asap_id/)                    {push(@$single_domain,{'data'=>$alias_col->{$id}->{"ASAP"},'highlight'=>$highlight_color});}
2564          elsif ($col =~ /jgi_id/)                     {push(@$single_domain,{'data'=>$alias_col->{$id}->{"JGI"},'highlight'=>$highlight_color});}
2565          elsif ($col =~ /lineage/)                   {push(@$single_domain,{'data'=>$lineages->{$tax},'highlight'=>$highlight_color});}
2566          elsif ($col =~ /figfam/)                     {push(@$single_domain,{'data'=>"<a href='?page=FigFamViewer&figfam=" . $ff . "' target='_new'>" . $ff . "</a>",'highlight'=>$highlight_color});}
2567        }
2568        push(@$data,$single_domain);
2569      }
2570    
2571      $content = $data;
2572      return ($content);
2573    }
2574    
2575    sub get_box_column{
2576        my ($ids) = @_;
2577        my %column;
2578        foreach my $id (@$ids){
2579            my $field_name = "tables_" . $id;
2580            my $pair_name = "visual_" . $id;
2581            my $cell_name = "cell_" . $id;
2582            $column{$id} = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name', '$cell_name');">);
2583        }
2584        return (%column);
2585    }
2586    
2587    sub get_figfam_column{
2588        my ($ids, $fig, $cgi) = @_;
2589        my $column;
2590    
2591        my $figfam_data = &FIG::get_figfams_data();
2592        my $figfams = new FFs($figfam_data);
2593    
2594        foreach my $id (@$ids){
2595            my ($ff);
2596            if ($id =~ /\.peg\./){
2597                ($ff) =  $figfams->families_containing_peg($id);
2598            }
2599            if ($ff){
2600                push (@$column, "<a href='?page=FigFamViewer&figfam=" . $ff . "' target='_new'>" . $ff . "</a>");
2601            }
2602            else{
2603                push (@$column, " ");
2604            }
2605        }
2606    
2607        return $column;
2608    }
2609    
2610    sub get_subsystems_column{
2611        my ($ids,$fig,$cgi,$returnType) = @_;
2612    
2613        my %in_subs  = $fig->subsystems_for_pegs($ids);
2614        my ($column, $ss);
2615        foreach my $id (@$ids){
2616            my @in_sub = @{$in_subs{$id}} if (defined $in_subs{$id});
2617            my @subsystems;
2618    
2619            if (@in_sub > 0) {
2620                foreach my $array(@in_sub){
2621                    my $ss = $array->[0];
2622                    $ss =~ s/_/ /ig;
2623                    push (@subsystems, "-" . $ss);
2624                }
2625                my $in_sub_line = join ("<br>", @subsystems);
2626                $ss->{$id} = $in_sub_line;
2627            } else {
2628                $ss->{$id} = "None added";
2629            }
2630            push (@$column, $ss->{$id});
2631        }
2632    
2633        if ($returnType eq 'hash') { return $ss; }
2634        elsif ($returnType eq 'array') { return $column; }
2635    }
2636    
2637    sub get_lineage_column{
2638        my ($ids, $fig, $cgi) = @_;
2639    
2640        my $lineages = $fig->taxonomy_list();
2641    
2642        foreach my $id (@$ids){
2643            my $genome = $fig->genome_of($id);
2644            if ($lineages->{$genome}){
2645    #           push (@$column, qq~<table style='border-style:hidden;'><tr><td style='background-color: #ffffff;'>~ . $lineages->{$genome} . qq~</td></tr</table>~);
2646                push (@$column, $lineages->{$genome});
2647            }
2648            else{
2649                push (@$column, " ");
2650            }
2651        }
2652        return $column;
2653    }
2654    
2655    sub match_color {
2656        my ( $b, $e, $n , $rgb) = @_;
2657        my ( $l, $r ) = ( $e > $b ) ? ( $b, $e ) : ( $e, $b );
2658        my $hue = 5/6 * 0.5*($l+$r)/$n - 1/12;
2659        my $cov = ( $r - $l + 1 ) / $n;
2660        my $sat = 1 - 10 * $cov / 9;
2661        my $br  = 1;
2662        if ($rgb){
2663            return html2rgb( rgb2html( hsb2rgb( $hue, $sat, $br ) ) );
2664        }
2665        else{
2666            rgb2html( hsb2rgb( $hue, $sat, $br ) );
2667        }
2668    }
2669    
2670    sub hsb2rgb {
2671        my ( $h, $s, $br ) = @_;
2672        $h = 6 * ($h - floor($h));
2673        if ( $s  > 1 ) { $s  = 1 } elsif ( $s  < 0 ) { $s  = 0 }
2674        if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }
2675        my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1,      $h,     0      )
2676                                          : ( $h <= 2 ) ? ( 2 - $h, 1,      0      )
2677                                          :               ( 0,      1,      $h - 2 )
2678                                          )
2679                                        : ( ( $h <= 4 ) ? ( 0,      4 - $h, 1      )
2680                                          : ( $h <= 5 ) ? ( $h - 4, 0,      1      )
2681                                          :               ( 1,      0,      6 - $h )
2682                                          );
2683        ( ( $r * $s + 1 - $s ) * $br,
2684          ( $g * $s + 1 - $s ) * $br,
2685          ( $b * $s + 1 - $s ) * $br
2686        )
2687    }
2688    
2689    sub html2rgb {
2690        my ($hex) = @_;
2691        my ($r,$g,$b) = ($hex) =~ /^\#(\w\w)(\w\w)(\w\w)/;
2692        my $code = { 'A'=>10, 'B'=>11, 'C'=>12, 'D'=>13, 'E'=>14, 'F'=>15,
2693                     1=>1, 2=>2, 3=>3, 4=>4, 5=>5, 6=>6, 7=>7, 8=>8, 9=>9};
2694    
2695        my @R = split(//, $r);
2696        my @G = split(//, $g);
2697        my @B = split(//, $b);
2698    
2699        my $red = ($code->{uc($R[0])}*16)+$code->{uc($R[1])};
2700        my $green = ($code->{uc($G[0])}*16)+$code->{uc($G[1])};
2701        my $blue = ($code->{uc($B[0])}*16)+$code->{uc($B[1])};
2702    
2703        my $rgb = [$red, $green, $blue];
2704        return $rgb;
2705    
2706    }
2707    
2708    sub rgb2html {
2709        my ( $r, $g, $b ) = @_;
2710        if ( $r > 1 ) { $r = 1 } elsif ( $r < 0 ) { $r = 0 }
2711        if ( $g > 1 ) { $g = 1 } elsif ( $g < 0 ) { $g = 0 }
2712        if ( $b > 1 ) { $b = 1 } elsif ( $b < 0 ) { $b = 0 }
2713        sprintf("#%02x%02x%02x", int(255.999*$r), int(255.999*$g), int(255.999*$b) )
2714    }
2715    
2716    sub floor {
2717        my $x = $_[0];
2718        defined( $x ) || return undef;
2719        ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x )
2720    }
2721    
2722    sub get_function_color_cell{
2723      my ($functions, $fig) = @_;
2724    
2725      # figure out the quantity of each function
2726      my %hash;
2727      foreach my $key (keys %$functions){
2728        my $func = $functions->{$key};
2729        $hash{$func}++;
2730      }
2731    
2732      my %func_colors;
2733      my $count = 1;
2734      foreach my $key (sort {$hash{$b}<=>$hash{$a}} keys %hash){
2735        $func_colors{$key}=$count;
2736        $count++;
2737      }
2738    
2739      return \%func_colors;
2740    }
2741    
2742    sub get_essentially_identical{
2743        my ($fid,$dataset,$fig) = @_;
2744        #my $fig = new FIG;
2745    
2746        my %id_list;
2747        #my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);
2748    
2749        foreach my $thing (@$dataset){
2750            if($thing->class eq "IDENTICAL"){
2751                my $rows = $thing->rows;
2752                my $count_identical = 0;
2753                foreach my $row (@$rows) {
2754                    my $id = $row->[0];
2755                    if (($id ne $fid) && ($fig->function_of($id))) {
2756                        $id_list{$id} = 1;
2757                    }
2758                }
2759            }
2760        }
2761    
2762    #    foreach my $id (@maps_to) {
2763    #        if (($id ne $fid) && ($fig->function_of($id))) {
2764    #           $id_list{$id} = 1;
2765    #        }
2766    #    }
2767        return(%id_list);
2768    }
2769    
2770    
2771    sub get_evidence_column{
2772        my ($ids,$attributes,$fig,$cgi,$returnType) = @_;
2773        my ($column, $code_attributes);
2774    
2775        if (! defined $attributes) {
2776            my @attributes_array = $fig->get_attributes($ids);
2777            $attributes = \@attributes_array;
2778        }
2779    
2780        my @codes = grep { $_->[1] =~ /^evidence_code/i } @$attributes;
2781        foreach my $key (@codes){
2782            push (@{$code_attributes->{$key->[0]}}, $key);
2783        }
2784    
2785        foreach my $id (@$ids){
2786            # add evidence code with tool tip
2787            my $ev_codes=" &nbsp; ";
2788    
2789            my @codes = @{$code_attributes->{$id}} if (defined @{$code_attributes->{$id}});
2790            my @ev_codes = ();
2791            foreach my $code (@codes) {
2792                my $pretty_code = $code->[2];
2793                if ($pretty_code =~ /;/) {
2794                    my ($cd, $ss) = split(";", $code->[2]);
2795                    if ($cd =~ /ilit|dlit/){
2796                        my ($type,$pubmed_id) = ($cd) =~ /(.*?)\((.*)\)/;
2797                        my $publink = &HTML::alias_url($pubmed_id,'PMID');
2798                        $cd = $type . "(<a href='" . $publink . "'>" . $pubmed_id . "</a>)";
2799                    }
2800                    $ss =~ s/_/ /g;
2801                    $pretty_code = $cd;# . " in " . $ss;
2802                }
2803                push(@ev_codes, $pretty_code);
2804            }
2805    
2806            if (scalar(@ev_codes) && $ev_codes[0]) {
2807                my $ev_code_help=join("<br />", map {&HTML::evidence_codes_explain($_)} @ev_codes);
2808                $ev_codes = $cgi->a(
2809                                    {
2810                                        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));
2811            }
2812    
2813            if ($returnType eq 'hash') { $column->{$id}=$ev_codes; }
2814            elsif ($returnType eq 'array') { push (@$column, $ev_codes); }
2815        }
2816        return $column;
2817    }
2818    
2819    sub get_attrb_column{
2820        my ($ids, $attributes, $fig, $cgi, $colName, $attrbName, $returnType) = @_;
2821    
2822        my ($column, %code_attributes, %attribute_locations);
2823        my $dbmaster = DBMaster->new(-database =>'Ontology',
2824                                     -host     => $WebConfig::DBHOST,
2825                                     -user     => $WebConfig::DBUSER,
2826                                     -password => $WebConfig::DBPWD);
2827    
2828        if ($colName eq "pfam"){
2829            if (! defined $attributes) {
2830                my @attributes_array = $fig->get_attributes($ids);
2831                $attributes = \@attributes_array;
2832            }
2833    
2834            my @codes = grep { $_->[1] =~ /^$attrbName/i } @$attributes;
2835            foreach my $key (@codes){
2836                my $name = $key->[1];
2837                if ($name =~ /_/){
2838                    ($name) = ($key->[1]) =~ /(.*?)_/;
2839                }
2840                push (@{$code_attributes{$key->[0]}}, $name);
2841                push (@{$attribute_location{$key->[0]}{$name}}, $key->[2]);
2842            }
2843    
2844            foreach my $id (@$ids){
2845                # add pfam code
2846                my $pfam_codes=" &nbsp; ";
2847                my @pfam_codes = "";
2848                my %description_codes;
2849    
2850                if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {
2851                    my @ncodes = @{$code_attributes{$id}} if (defined @{$code_attributes{$id}});
2852                    @pfam_codes = ();
2853    
2854                    # get only unique values
2855                    my %saw;
2856                    foreach my $key (@ncodes) {$saw{$key}=1;}
2857                    @ncodes = keys %saw;
2858    
2859                    foreach my $code (@ncodes) {
2860                        my @parts = split("::",$code);
2861                        my $pfam_link = "<a href=http://pfam.sanger.ac.uk/family?acc=" . $parts[1] . ">$parts[1]</a>";
2862    
2863    #                   # get the locations for the domain
2864    #                   my @locs;
2865    #                   foreach my $part (@{$attribute_location{$id}{$code}}){
2866    #                       my ($loc) = ($part) =~ /\;(.*)/;
2867    #                       push (@locs,$loc);
2868    #                   }
2869    #                   my %locsaw;
2870    #                   foreach my $key (@locs) {$locsaw{$key}=1;}
2871    #                   @locs = keys %locsaw;
2872    #
2873    #                   my $locations = join (", ", @locs);
2874    #
2875                        if (defined ($description_codes{$parts[1]})){
2876                            push(@pfam_codes, "$parts[1]");
2877                        }
2878                        else {
2879                            my $description = $dbmaster->pfam->get_objects( { 'id' => $parts[1] } );
2880                            $description_codes{$parts[1]} = $description->[0]->{term};
2881                            push(@pfam_codes, "$pfam_link");
2882                        }
2883                    }
2884    
2885                    if ($returnType eq 'hash') { $column->{$id} = join("<br><br>", @pfam_codes); }
2886                    elsif ($returnType eq 'array') { push (@$column, join("<br><br>", @pfam_codes)); }
2887                }
2888            }
2889        }
2890        elsif ($colName eq 'cellular_location'){
2891            if (! defined $attributes) {
2892                my @attributes_array = $fig->get_attributes($ids);
2893                $attributes = \@attributes_array;
2894            }
2895    
2896            my @codes = grep { $_->[1] =~ /^$attrbName/i } @$attributes;
2897            foreach my $key (@codes){
2898                my ($loc) = ($key->[1]) =~ /::(.*)/;
2899                my ($new_loc, @all);
2900                @all = split (//, $loc);
2901                my $count = 0;
2902                foreach my $i (@all){
2903                    if ( ($i eq uc($i)) && ($count > 0) ){
2904                        $new_loc .= " " . $i;
2905                    }
2906                    else{
2907                        $new_loc .= $i;
2908                    }
2909                    $count++;
2910                }
2911                push (@{$code_attributes{$key->[0]}}, [$new_loc, $key->[2]]);
2912            }
2913    
2914            foreach my $id (@$ids){
2915                my (@values, $entry);
2916                #@values = (" ");
2917                if (defined @{$code_attributes{$id}}){
2918                    my @ncodes = @{$code_attributes{$id}};
2919                    foreach my $code (@ncodes){
2920                        push (@values, $code->[0] . ", " . $code->[1]);
2921                    }
2922                }
2923                else{
2924                    @values = ("Not available");
2925                }
2926    
2927                if ($returnType eq 'hash') { $column->{$id} = join ("<BR>", @values); }
2928                elsif ($returnType eq 'array') { push (@$column, join ("<BR>", @values)); }
2929            }
2930        }
2931        elsif ( ($colName eq 'mw') || ($colName eq 'transmembrane') || ($colName eq 'similar_to_human') ||
2932                ($colName eq 'signal_peptide') || ($colName eq 'isoelectric') ){
2933            if (! defined $attributes) {
2934                my @attributes_array = $fig->get_attributes($ids);
2935                $attributes = \@attributes_array;
2936            }
2937    
2938            my @codes = grep { $_->[1] =~ /^$attrbName/i } @$attributes;
2939            foreach my $key (@codes){
2940                push (@{$code_attributes{$key->[0]}}, $key->[2]);
2941            }
2942    
2943            foreach my $id (@$ids){
2944                my (@values, $entry);
2945                #@values = (" ");
2946                if (defined @{$code_attributes{$id}}){
2947                    my @ncodes = @{$code_attributes{$id}};
2948                    foreach my $code (@ncodes){
2949                        push (@values, $code);
2950                    }
2951                }
2952                else{
2953                    @values = ("Not available");
2954                }
2955    
2956                if ($returnType eq 'hash') { $column->{$id} = join ("<BR>", @values); }
2957                elsif ($returnType eq 'array') { push (@$column, join ("<BR>", @values)); }
2958            }
2959        }
2960        elsif ( ($colName eq 'habitat') || ($colName eq 'temperature') || ($colName eq 'temp_range') ||
2961                ($colName eq 'oxygen') || ($colName eq 'pathogenic') || ($colName eq 'pathogenic_in') ||
2962                ($colName eq 'salinity') || ($colName eq 'motility') || ($colName eq 'gram_stain') ||
2963                ($colName eq 'endospores') || ($colName eq 'shape') || ($colName eq 'disease') ||
2964                ($colName eq 'gc_content') ) {
2965            if (! defined $attributes) {
2966                my @attributes_array = $fig->get_attributes(undef,$attrbName);
2967                $attributes = \@attributes_array;
2968            }
2969    
2970            my $genomes_with_phenotype;
2971            foreach my $attribute (@$attributes){
2972                my $genome = $attribute->[0];
2973                $genomes_with_phenotype->{$genome} = $attribute->[2];
2974            }
2975    
2976            foreach my $id (@$ids){
2977                my $genome = $fig->genome_of($id);
2978                my @values = (' ');
2979                if (defined $genomes_with_phenotype->{$genome}){
2980                    push (@values, $genomes_with_phenotype->{$genome});
2981                }
2982                if ($returnType eq 'hash') { $column->{$id} = join ("<BR>", @values); }
2983                elsif ($returnType eq 'array') { push (@$column, join ("<BR>", @values)); }
2984            }
2985        }
2986    
2987        return $column;
2988    }
2989    
2990    sub get_aclh_aliases {
2991        my ($ids,$fig,$db,$cgi,$returnType) = @_;
2992        my $db_array;
2993    
2994        my $id_line = join (",", @$ids);
2995        my $aclh_url = "http://clearinghouse.nmpdr.org/aclh.cgi?page=SearchResults&raw_dump=1&query=" . $id_line;
2996    
2997    
2998    }
2999    
3000    sub get_id_aliases {
3001        my ($id, $fig) = @_;
3002        my $aliases = {};
3003    
3004        my $org = $fig->org_of($id);
3005        my $url = "http://clearinghouse.nmpdr.org/aclh.cgi?page=SearchResults&raw_dump=1&query=$id";
3006        if ( my $form = &LWP::Simple::get($url) ) {
3007            my ($block) = ($form) =~ /<pre>(.*)<\/pre>/s;
3008            foreach my $line (split /\n/, $block){
3009                my @values = split /\t/, $line;
3010                next if ($values[3] eq "Expert");
3011                if (($values[1] =~ /$org/) || ($org =~ /$values[1]/) && (! defined $aliases->{$values[4]}) ){
3012                    $aliases->{$values[4]} = $values[0];
3013                }
3014            }
3015        }
3016    
3017        return $aliases;
3018    }
3019    
3020    sub get_db_aliases {
3021        my ($ids,$fig,$db,$cgi,$returnType) = @_;
3022        my $db_array;
3023        my $all_aliases = $fig->feature_aliases_bulk($ids);
3024        foreach my $id (@$ids){
3025    #       my @all_aliases = grep { $_ ne $id and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($id);
3026            my $id_org = $fig->org_of($id);
3027    
3028            foreach my $alias (@{$$all_aliases{$id}}){
3029    #       foreach my $alias (@all_aliases){
3030                my $id_db = &Observation::get_database($alias);
3031                next if ( ($id_db ne $db) && ($db ne 'all') );
3032                next if ($aliases->{$id}->{$db});
3033                my $alias_org = $fig->org_of($alias);
3034    #           if (($id ne $peg) && ( ($alias_org =~ /$id_org/) || ($id_org =~ /$alias_org/)) ) {
3035                    #push(@funcs, [$id,$id_db,$tmp]);
3036                    $aliases->{$id}->{$id_db} = &HTML::set_prot_links($cgi,$alias);
3037    #           }
3038            }
3039            if (!defined( $aliases->{$id}->{$db})){
3040                $aliases->{$id}->{$db} = " ";
3041            }
3042            #push (@$db_array, {'data'=>  $aliases->{$id}->{$db},'highlight'=>"#ffffff"});
3043            push (@$db_array, $aliases->{$id}->{$db});
3044        }
3045    
3046        if ($returnType eq 'hash') { return $aliases; }
3047        elsif ($returnType eq 'array') { return $db_array; }
3048    }
3049    
3050    
3051    
3052    sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
3053    
3054    sub color {
3055        my ($evalue) = @_;
3056        my $palette = WebColors::get_palette('vitamins');
3057        my $color;
3058        if ($evalue <= 1e-170){        $color = $palette->[0];    }
3059        elsif (($evalue <= 1e-120) && ($evalue > 1e-170)){        $color = $palette->[1];    }
3060        elsif (($evalue <= 1e-90) && ($evalue > 1e-120)){        $color = $palette->[2];    }
3061        elsif (($evalue <= 1e-70) && ($evalue > 1e-90)){        $color = $palette->[3];    }
3062        elsif (($evalue <= 1e-40) && ($evalue > 1e-70)){        $color = $palette->[4];    }
3063        elsif (($evalue <= 1e-20) && ($evalue > 1e-40)){        $color = $palette->[5];    }
3064        elsif (($evalue <= 1e-5) && ($evalue > 1e-20)){        $color = $palette->[6];    }
3065        elsif (($evalue <= 1) && ($evalue > 1e-5)){        $color = $palette->[7];    }
3066        elsif (($evalue <= 10) && ($evalue > 1)){        $color = $palette->[8];    }
3067        else{        $color = $palette->[9];    }
3068        return ($color);
3069    }
3070    
3071    
3072    ############################
3073    package Observation::Cluster;
3074    
3075    use base qw(Observation);
3076    
3077    sub new {
3078    
3079        my ($class,$dataset) = @_;
3080        my $self = $class->SUPER::new($dataset);
3081        $self->{context} = $dataset->{'context'};
3082        bless($self,$class);
3083        return $self;
3084    }
3085    
3086    sub display {
3087        my ($self,$gd,$selected_taxonomies,$taxes,$sims_array,$fig) = @_;
3088    
3089        $taxes = $fig->taxonomy_list();
3090    
3091        my $fid = $self->fig_id;
3092        my $compare_or_coupling = $self->context;
3093        my $gd_window_size = $gd->window_size;
3094        my $range = $gd_window_size;
3095        my $all_regions = [];
3096        my $gene_associations={};
3097    
3098        #get the organism genome
3099        my $target_genome = $fig->genome_of($fid);
3100        $gene_associations->{$fid}->{"organism"} = $target_genome;
3101        $gene_associations->{$fid}->{"main_gene"} = $fid;
3102        $gene_associations->{$fid}->{"reverse_flag"} = 0;
3103    
3104        # get location of the gene
3105        my $data = $fig->feature_location($fid);
3106        my ($contig, $beg, $end);
3107        my %reverse_flag;
3108    
3109        if ($data =~ /(.*)_(\d+)_(\d+)$/){
3110            $contig = $1;
3111            $beg = $2;
3112            $end = $3;
3113        }
3114    
3115        my $offset;
3116        my ($region_start, $region_end);
3117        if ($beg < $end)
3118        {
3119            $region_start = $beg - ($range);
3120            $region_end = $end+ ($range);
3121            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
3122        }
3123        else
3124        {
3125            $region_start = $end-($range);
3126            $region_end = $beg+($range);
3127            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
3128            $reverse_flag{$target_genome} = $fid;
3129            $gene_associations->{$fid}->{"reverse_flag"} = 1;
3130        }
3131    
3132        # call genes in region
3133        my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_end);
3134        #foreach my $feat (@$target_gene_features){
3135        #   push (@$all_regions, $feat) if ($feat =~ /peg/);
3136        #}
3137        push(@$all_regions,$target_gene_features);
3138        my (@start_array_region);
3139        push (@start_array_region, $offset);
3140    
3141        my %all_genes;
3142        my %all_genomes;
3143        foreach my $feature (@$target_gene_features){
3144            #if ($feature =~ /peg/){
3145                $all_genes{$feature} = $fid; $gene_associations->{$feature}->{"main_gene"}=$fid;
3146            #}
3147        }
3148    
3149        my @selected_sims;
3150    
3151        if ($compare_or_coupling eq "sims"){
3152            # get the selected boxes
3153            my @selected_taxonomy = @$selected_taxonomies;
3154    
3155            # get the similarities and store only the ones that match the lineages selected
3156            if (@selected_taxonomy > 0){
3157                foreach my $sim (@$sims_array){
3158                    next if ($sim->class ne "SIM");
3159                    next if ($sim->acc !~ /fig\|/);
3160    
3161                    #my $genome = $fig->genome_of($sim->[1]);
3162                    my $genome = $fig->genome_of($sim->acc);
3163                    #my ($genome1) = ($genome) =~ /(.*)\./;
3164                    my $lineage = $taxes->{$genome};
3165                    #my $lineage = $fig->taxonomy_of($fig->genome_of($genome));
3166                    foreach my $taxon(@selected_taxonomy){
3167                        if ($lineage =~ /$taxon/){
3168                            #push (@selected_sims, $sim->[1]);
3169                            push (@selected_sims, $sim->acc);
3170                        }
3171                    }
3172                }
3173            }
3174            else{
3175                my $simcount = 0;
3176                foreach my $sim (@$sims_array){
3177                    next if ($sim->class ne "SIM");
3178                    next if ($sim->acc !~ /fig\|/);
3179    
3180                    push (@selected_sims, $sim->acc);
3181                    $simcount++;
3182                    last if ($simcount > 4);
3183                }
3184            }
3185    
3186            my %saw;
3187            @selected_sims = grep(!$saw{$_}++, @selected_sims);
3188    
3189            # get the gene context for the sorted matches
3190            foreach my $sim_fid(@selected_sims){
3191                #get the organism genome
3192                my $sim_genome = $fig->genome_of($sim_fid);
3193                $gene_associations->{$sim_fid}->{"organism"} = $sim_genome;
3194                $gene_associations->{$sim_fid}->{"main_gene"} = $sim_fid;
3195                $gene_associations->{$sim_fid}->{"reverse_flag"} = 0;
3196    
3197                # get location of the gene
3198                my $data = $fig->feature_location($sim_fid);
3199                my ($contig, $beg, $end);
3200    
3201                if ($data =~ /(.*)_(\d+)_(\d+)$/){
3202                    $contig = $1;
3203                    $beg = $2;
3204                    $end = $3;
3205                }
3206    
3207                my $offset;
3208                my ($region_start, $region_end);
3209                if ($beg < $end)
3210                {
3211                    $region_start = $beg - ($range/2);
3212                    $region_end = $end+($range/2);
3213                    $offset = ($beg+(($end-$beg)/2))-($gd_window_size/2);
3214                }
3215                else
3216                {
3217                    $region_start = $end-($range/2);
3218                    $region_end = $beg+($range/2);
3219                    $offset = ($end+(($beg-$end)/2))-($gd_window_size/2);
3220                    $reverse_flag{$sim_genome} = $sim_fid;
3221                    $gene_associations->{$sim_fid}->{"reverse_flag"} = 1;
3222                }
3223    
3224                # call genes in region
3225                my ($sim_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($sim_genome, $contig, $region_start, $region_end);
3226                push(@$all_regions,$sim_gene_features);
3227                push (@start_array_region, $offset);
3228                foreach my $feature (@$sim_gene_features){ $all_genes{$feature} = $sim_fid;$gene_associations->{$feature}->{"main_gene"}=$sim_fid;}
3229                $all_genomes{$sim_genome} = 1;
3230            }
3231    
3232        }
3233    
3234        #print STDERR "START CLUSTER OF GENES IN COMP REGION: " . `date`;
3235        # cluster the genes
3236        my @all_pegs = keys %all_genes;
3237        my $color_sets = &cluster_genes($fig,\@all_pegs,$fid);
3238        #print STDERR "END CLUSTER OF GENES IN COMP REGION: ". `date`;
3239        my %in_subs  = $fig->subsystems_for_pegs(\@all_pegs);
3240    
3241        foreach my $region (@$all_regions){
3242            my $sample_peg = @$region[0];
3243            my $region_genome = $fig->genome_of($sample_peg);
3244            my $region_gs = $fig->genus_species($region_genome);
3245            my $abbrev_name = $fig->abbrev($region_gs);
3246            #my ($genome1) = ($region_genome) =~ /(.*?)\./;
3247            my $lineage = $taxes->{$region_genome};
3248            #my $lineage = $fig->taxonomy_of($region_genome);
3249            #$region_gs .= "Lineage:$lineage";
3250            my $line_config = { 'title' => $region_gs,
3251                                'short_title' => $abbrev_name,
3252                                'basepair_offset' => '0'
3253                                };
3254    
3255            my $offsetting = shift @start_array_region;
3256    
3257            my $second_line_config = { 'title' => "$lineage",
3258                                       'short_title' => "",
3259                                       'basepair_offset' => '0',
3260                                       'no_middle_line' => '1'
3261                                       };
3262    
3263            my $line_data = [];
3264            my $second_line_data = [];
3265    
3266            # initialize variables to check for overlap in genes
3267            my ($prev_start, $prev_stop, $prev_fig, $second_line_flag);
3268            my $major_line_flag = 0;
3269            my $prev_second_flag = 0;
3270    
3271            foreach my $fid1 (@$region){
3272                $second_line_flag = 0;
3273                my $element_hash;
3274                my $links_list = [];
3275                my $descriptions = [];
3276    
3277                my $color = $color_sets->{$fid1};
3278    
3279                # get subsystem information
3280                my $function = $fig->function_of($fid1);
3281                my $url_link = "?page=Annotation&feature=".$fid1;
3282    
3283                my $link;
3284                $link = {"link_title" => $fid1,
3285                         "link" => $url_link};
3286                push(@$links_list,$link);
3287    
3288                my @subs = @{$in_subs{$fid1}} if (defined $in_subs{$fid1});
3289                my @subsystems;
3290                foreach my $array (@subs){
3291                    my $subsystem = $$array[0];
3292                    my $ss = $subsystem;
3293                    $ss =~ s/_/ /ig;
3294                    push (@subsystems, $ss);
3295                    my $link;
3296                    $link = {"link" => "?page=Subsystems&subsystem=$subsystem",
3297                             "link_title" => $ss};
3298                    push(@$links_list,$link);
3299                }
3300    
3301                if ($fid1 eq $fid){
3302                    my $link;
3303                    $link = {"link_title" => "Annotate this sequence",
3304                             "link" => "$FIG_Config::cgi_url/seedviewer.cgi?page=Commentary"};
3305                    push (@$links_list,$link);
3306                }
3307    
3308                my $description_function;
3309                $description_function = {"title" => "function",
3310                                         "value" => $function};
3311                push(@$descriptions,$description_function);
3312    
3313                my $description_ss;
3314                my $ss_string = join (", ", @subsystems);
3315                $description_ss = {"title" => "subsystems",
3316                                   "value" => $ss_string};
3317                push(@$descriptions,$description_ss);
3318    
3319    
3320                my $fid_location = $fig->feature_location($fid1);
3321                if($fid_location =~/(.*)_(\d+)_(\d+)$/){
3322                    my($start,$stop);
3323                    $start = $2 - $offsetting;
3324                    $stop = $3 - $offsetting;
3325    
3326                    if ( (($prev_start) && ($prev_stop) ) &&
3327                         ( ($start < $prev_start) || ($start < $prev_stop) ||
3328                           ($stop < $prev_start) || ($stop < $prev_stop) )){
3329                        if (($second_line_flag == 0) && ($prev_second_flag == 0)) {
3330                            $second_line_flag = 1;
3331                            $major_line_flag = 1;
3332                        }
3333                    }
3334                    $prev_start = $start;
3335                    $prev_stop = $stop;
3336                    $prev_fig = $fid1;
3337    
3338                    if ((defined($reverse_flag{$region_genome})) && ($reverse_flag{$region_genome} eq $all_gnes{$fid1})){
3339                        $start = $gd_window_size - $start;
3340                        $stop = $gd_window_size - $stop;
3341                    }
3342    
3343                    my $title = $fid1;
3344                    if ($fid1 eq $fid){
3345                        $title = "My query gene: $fid1";
3346                    }
3347    
3348                    $element_hash = {
3349                        "title" => $title,
3350                        "start" => $start,
3351                        "end" =>  $stop,
3352                        "type"=> 'arrow',
3353                        "color"=> $color,
3354                        "zlayer" => "2",
3355                        "links_list" => $links_list,
3356                        "description" => $descriptions
3357                    };
3358    
3359                    # if there is an overlap, put into second line
3360                    if ($second_line_flag == 1){ push(@$second_line_data,$element_hash); $prev_second_flag = 1;}
3361                    else{ push(@$line_data,$element_hash); $prev_second_flag = 0;}
3362    
3363                    if ($fid1 eq $fid){
3364                        $element_hash = {
3365                            "title" => 'Query',
3366                            "start" => $start,
3367                            "end" =>  $stop,
3368                            "type"=> 'bigbox',
3369                            "color"=> $color,
3370                            "zlayer" => "1"
3371                            };
3372    
3373                        # if there is an overlap, put into second line
3374                        if ($second_line_flag == 1){ push(@$second_line_data,$element_hash); $prev_second_flag = 1;}
3375                        else{ push(@$line_data,$element_hash); $prev_second_flag = 0;}
3376                    }
3377                }
3378            }
3379            $gd->add_line($line_data, $line_config);
3380            $gd->add_line($second_line_data, $second_line_config); # if ($major_line_flag == 1);
3381        }
3382        return ($gd, \@selected_sims);
3383    }
3384    
3385    sub cluster_genes {
3386        my($fig,$all_pegs,$peg) = @_;
3387        my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
3388    
3389        my @color_sets = ();
3390    
3391        $conn = &get_connections_by_similarity($fig,$all_pegs);
3392    
3393        for ($i=0; ($i < @$all_pegs); $i++) {
3394            if ($all_pegs->[$i] eq $peg) { $pegI = $i }
3395            if (! $seen{$i}) {
3396                $cluster = [$i];
3397                $seen{$i} = 1;
3398                for ($j=0; ($j < @$cluster); $j++) {
3399                    $x = $conn->{$cluster->[$j]};
3400                    foreach $k (@$x) {
3401                        if (! $seen{$k}) {
3402                            push(@$cluster,$k);
3403                            $seen{$k} = 1;
3404                        }
3405                    }
3406                }
3407    
3408                if ((@$cluster > 1) || ($cluster->[0] eq $pegI)) {
3409                    push(@color_sets,$cluster);
3410                }
3411            }
3412        }
3413        for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
3414        $red_set = $color_sets[$i];
3415        splice(@color_sets,$i,1);
3416        @color_sets = sort { @$b <=> @$a } @color_sets;
3417        unshift(@color_sets,$red_set);
3418    
3419        my $color_sets = {};
3420        for ($i=0; ($i < @color_sets); $i++) {
3421            foreach $x (@{$color_sets[$i]}) {
3422                $color_sets->{$all_pegs->[$x]} = $i;
3423            }
3424        }
3425        return $color_sets;
3426    }
3427    
3428    sub get_connections_by_similarity {
3429        my($fig,$all_pegs) = @_;
3430        my($i,$j,$tmp,$peg,%pos_of);
3431        my($sim,%conn,$x,$y);
3432    
3433        for ($i=0; ($i < @$all_pegs); $i++) {
3434            $tmp = $fig->maps_to_id($all_pegs->[$i]);
3435            push(@{$pos_of{$tmp}},$i);
3436            if ($tmp ne $all_pegs->[$i]) {
3437                push(@{$pos_of{$all_pegs->[$i]}},$i);
3438            }
3439        }
3440    
3441        foreach $y (keys(%pos_of)) {
3442            $x = $pos_of{$y};
3443            for ($i=0; ($i < @$x); $i++) {
3444                for ($j=$i+1; ($j < @$x); $j++) {
3445                    push(@{$conn{$x->[$i]}},$x->[$j]);
3446                    push(@{$conn{$x->[$j]}},$x->[$i]);
3447                }
3448            }
3449        }
3450    
3451        for ($i=0; ($i < @$all_pegs); $i++) {
3452            foreach $sim ($fig->sims($all_pegs->[$i],500,10,"raw")) {
3453                if (defined($x = $pos_of{$sim->id2})) {
3454                    foreach $y (@$x) {
3455                        push(@{$conn{$i}},$y);
3456                    }
3457                }
3458            }
3459        }
3460        return \%conn;
3461    }
3462    
3463    sub in {
3464        my($x,$xL) = @_;
3465        my($i);
3466    
3467        for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
3468        return ($i < @$xL);
3469    }
3470    
3471    #############################################
3472    #############################################
3473    package Observation::Commentary;
3474    
3475    use base qw(Observation);
3476    
3477    =head3 display_protein_commentary()
3478    
3479    =cut
3480    
3481    sub display_protein_commentary {
3482        my ($self,$dataset,$mypeg,$fig) = @_;
3483    
3484        my $all_rows = [];
3485        my $content;
3486        #my $fig = new FIG;
3487        my $cgi = new CGI;
3488        my $count = 0;
3489        my $peg_array = [];
3490        my ($evidence_column, $subsystems_column,  %e_identical);
3491    
3492        if (@$dataset != 1){
3493            foreach my $thing (@$dataset){
3494                if ($thing->class eq "SIM"){
3495                    push (@$peg_array, $thing->acc);
3496                }
3497            }
3498            # get the column for the evidence codes
3499            $evidence_column = &Observation::Sims::get_evidence_column($peg_array, undef, $fig, $cgi, 'hash');
3500    
3501            # get the column for the subsystems
3502            $subsystems_column = &Observation::Sims::get_subsystems_column($peg_array,$fig, $cgi, 'array');
3503    
3504            # get essentially identical seqs
3505            %e_identical = &Observation::Sims::get_essentially_identical($mypeg,$dataset,$fig);
3506        }
3507        else{
3508            push (@$peg_array, @$dataset);
3509        }
3510    
3511        my $selected_sims = [];
3512        foreach my $id (@$peg_array){
3513            last if ($count > 10);
3514            my $row_data = [];
3515            my ($set, $org, $ss, $ev, $function, $function_cell, $id_cell);
3516            if ($fig->org_of($id)){
3517                $org = $fig->org_of($id);
3518            }
3519            else{
3520                $org = "Data not available";
3521            }
3522            $function = $fig->function_of($id);
3523            if ($mypeg ne $id){
3524                $function_cell = "<input type='radio' name='function' id='$id' value='$function' onClick=\"clearText('setAnnotation');\">&nbsp;&nbsp;$function";
3525                $id_cell .= "<a href='?page=Annotation&feature=$id'>$id</a>"; # &HTML::set_prot_links($cgi,$id);
3526                if (defined($e_identical{$id})) { $id_cell .= "*";}
3527            }
3528            else{
3529                $function_cell = "&nbsp;&nbsp;$function";
3530                $id_cell = "<input type='checkbox' name='peg' id='peg$count' value='$id' checked='true'>";
3531                $id_cell .= "<a href='?page=Annotation&feature=$id'>$id</a>"; # &HTML::set_prot_links($cgi,$id);
3532            }
3533    
3534            push(@$row_data,$id_cell);
3535            push(@$row_data,$org);
3536            push(@$row_data, $subsystems_column->{$id}) if ($mypeg ne $id);
3537            push(@$row_data, $evidence_column->{$id}) if ($mypeg ne $id);
3538            push(@$row_data, $fig->translation_length($id));
3539            push(@$row_data,$function_cell);
3540            push(@$all_rows,$row_data);
3541            push (@$selected_sims, $id);
3542            $count++;
3543        }
3544    
3545        if ($count >0){
3546            $content = $all_rows;
3547        }
3548        else{
3549            $content = "<p>This PEG does not have enough similarities to change the commentary</p>";
3550        }
3551        return ($content,$selected_sims);
3552    }
3553    
3554    sub display_protein_history {
3555        my ($self, $id,$fig) = @_;
3556        my $all_rows = [];
3557        my $content;
3558    
3559        my $cgi = new CGI;
3560        my $count = 0;
3561        foreach my $feat ($fig->feature_annotations($id)){
3562            my $row = [];
3563            my $col1 = $feat->[2];
3564            my $col2 = $feat->[1];
3565            #my $text = "<pre>" . $feat->[3] . "<\pre>";
3566            my $text = $feat->[3];
3567    
3568            push (@$row, $col1);
3569            push (@$row, $col2);
3570            push (@$row, $text);
3571            push (@$all_rows, $row);
3572            $count++;
3573        }
3574        if ($count > 0){
3575            $content = $all_rows;
3576        }
3577        else {
3578            $content = "There is no history for this PEG";
3579        }
3580    
3581        return($content);
3582    }
3583    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3