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

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.33

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3