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

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.34

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3