[Bio] / FigKernelPackages / Observation.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Observation.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3