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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3