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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3