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

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.59

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3