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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3