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

Diff of /FigKernelPackages/Observation.pm

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

revision 1.2, Tue Jun 12 16:51:53 2007 UTC revision 1.29, Thu Aug 16 16:49:16 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;
13    
14  1;  1;
15    
# Line 21  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 64  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()
   
 The description of the hit. Taken from the data or from the our Ontology database for some cases e.g. IPR or PFAM.  
66    
67  B<Please note:>  each row in a displayed table
 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->{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};    return $self->{acc};
86  }  }
87    
# Line 100  Line 94 
94    
95  =over 9  =over 9
96    
97  =item sim (seq)  =item IDENTICAL (seq)
98    
99  =item bbh (seq)  =item SIM (seq)
100    
101  =item pch (fc)  =item BBH (seq)
102    
103  =item figfam (seq)  =item PCH (fc)
104    
105  =item ipr (dom)  =item FIGFAM (seq)
106    
107  =item cdd (dom)  =item IPR (dom)
108    
109  =item pfam (dom)  =item CDD (dom)
110    
111  =item signalp (dom)  =item PFAM (dom)
112    
113  =item cello (loc)  =item SIGNALP_CELLO_TMPRED (loc)
114    
115  =item tmhmm (loc)  =item PDB (seq)
116    
117  =item hmmtop (loc)  =item TMHMM (loc)
118    
119    =item HMMTOP (loc)
120    
121  =back  =back
122    
# Line 155  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 182  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    
202    return $self->{score};      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        return $self->{hstart};
215    }
216    
217    =head3 end()
218    
219    End of the hit in hit sequence.
220    
221  =cut  =cut
222    
223  sub display_method {  sub hstop {
224    my ($self) = @_;    my ($self) = @_;
225    
226    # add code here      return $self->{hstop};
   
   return $self->{display_method};  
227  }  }
228    
229  =head3 rank()  =head3 qlength()
230    
231  Returns an integer from 1 - 10 indicating the importance of this observations.  length of the query sequence in similarities
   
 Currently always returns 1.  
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    sub display {
283    
284    my $url = get_url($self->type, $self->acc);    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  It will probably have to:  sub display_table {
295    
296      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 $datasets =  
      [  
        [ { name => 'acc', value => '1234' },  
         { name => 'from', value => '4' },  
         { name => 'to', value => '400' },  
         ....  
        ],  
        [ { name => 'acc', value => '456' },  
         { name => 'from', value => '1' },  
         { name => 'to', value => '100' },  
         ....  
        ],  
        ...  
      ];  
    return $datasets;  
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) = @_;      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 attribut based observations      # call function that fetches attribute based observations
314    # returns an array of arrays of hashes    # returns an array of arrays of hashes
   #  
   get_attribute_based_observations($fid,\@matched_datasets);  
315    
316    # read sims + bbh (enrich BBHs with sims coordindates etc)      if($scope){
317    # read pchs          get_cluster_observations($fid,\@matched_datasets,$scope);
318    # read figfam match data from 48hr directory (BobO knows how do do this!)      }
319    # what sources of evidence did I miss?      else{
320            my %domain_classes;
321            my @attributes = $fig->get_attributes($fid);
322            $domain_classes{'CDD'} = 1;
323            get_identical_proteins($fid,\@matched_datasets);
324            get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets,\@attributes);
325            get_sims_observations($fid,\@matched_datasets);
326            get_functional_coupling($fid,\@matched_datasets);
327            get_attribute_based_location_observations($fid,\@matched_datasets,\@attributes);
328            get_pdb_observations($fid,\@matched_datasets,\@attributes);
329        }
330    
331    foreach my $dataset (@matched_datasets) {    foreach my $dataset (@matched_datasets) {
332      my $object = $self->new();          my $object;
333      foreach my $attribute (@$dataset) {          if($dataset->{'type'} eq "dom"){
334        $object->{$attribute->{'name'}} = $attribute->{'value'};              $object = Observation::Domain->new($dataset);
335      }      }
336  #    $object->{$attribute->{'feature_id'}} = $attribute->{$fid};          if($dataset->{'class'} eq "PCH"){
337      push (@$objects, $object);              $object = Observation::FC->new($dataset);
338            }
339            if ($dataset->{'class'} eq "IDENTICAL"){
340                $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"){
346                $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);
356        }
357    
358    return $objects;    return $objects;
359    
360    }
361    
362    =head3 display_housekeeping
363    This method returns the housekeeping data for a given peg in a table format
364    
365    =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        $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        $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        $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        $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        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        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            # group ids by aliases
413            my %db_aliases;
414            foreach my $key (sort {$groups{$a} cmp $groups{$b}} keys %groups){
415                push (@{$db_aliases{$groups{$key}}}, $key);
416            }
417    
418    
419            $content .= qq(<tr><td>Aliases</td><td><table border="0">);
420            foreach my $key (sort keys %db_aliases){
421                $content .= qq(<tr><td>$key:</td><td>) . join(", ", @{$db_aliases{$key}}) . qq(</td></tr\n);
422            }
423            $content .= qq(</td></tr></table>\n);
424        }
425    
426        $content .= qq(</table><p>\n);
427    
428        return ($content);
429    }
430    
431    =head3 get_sims_summary
432    This method uses as input the similarities of a peg and creates a tree view of their taxonomy
433    
434    =cut
435    
436    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        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        foreach my $key (keys %{$families{children}}){
455            $families{count}{$key} = @{$families{children}{$key}};
456    
457            my %saw;
458            my @out = grep(!$saw{$_}++, @{$families{children}{$key}});
459            $families{children}{$key} = \@out;
460        }
461        return (\%families);
462  }  }
463    
464  =head1 Internal Methods  =head1 Internal Methods
# Line 355  Line 469 
469    
470  =cut  =cut
471    
472    sub get_attribute_based_domain_observations{
473    
474  =head3 get_url (internal)      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)
475        my ($fid,$domain_classes,$datasets_ref,$attributes_ref) = (@_);
476    
477  get_url() return a valid URL or undef for any observation.      my $fig = new FIG;
478    
479  URLs are constructed by looking at the Accession acc()  and  name()      foreach my $attr_ref (@$attributes_ref) {
480    #    foreach my $attr_ref ($fig->get_attributes($fid)) {
481            my $key = @$attr_ref[1];
482            my @parts = split("::",$key);
483            my $class = $parts[0];
484    
485            if($domain_classes->{$parts[0]}){
486                my $val = @$attr_ref[2];
487                if($val =~/^(\d+\.\d+|0\.0);(\d+)-(\d+)/){
488                    my $raw_evalue = $1;
489                    my $from = $2;
490                    my $to = $3;
491                    my $evalue;
492                    if($raw_evalue =~/(\d+)\.(\d+)/){
493                        my $part2 = 1000 - $1;
494                        my $part1 = $2/100;
495                        $evalue = $part1."e-".$part2;
496                    }
497                    else{
498                        $evalue = "0.0";
499                    }
500    
501                    my $dataset = {'class' => $class,
502                                   'acc' => $key,
503                                   'type' => "dom" ,
504                                   'evalue' => $evalue,
505                                   'start' => $from,
506                                   'stop' => $to,
507                                   'fig_id' => $fid,
508                                   'score' => $raw_evalue
509                                   };
510    
511  Info from both attributes is combined with a table of base URLs stored in this function.                  push (@{$datasets_ref} ,$dataset);
512                }
513            }
514        }
515    }
516    
517  =cut  sub get_attribute_based_location_observations{
518    
519  sub get_url {      my ($fid,$datasets_ref, $attributes_ref) = (@_);
520        my $fig = new FIG;
521    
522   my ($self) = @_;      my $location_attributes = ['SignalP','CELLO','TMPRED'];
  my $url='';  
523    
524  # a hash with a URL for each observation; identified by name()      my $dataset = {'type' => "loc",
525  #my $URL             => { 'PFAM' => "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?" ,\                     'class' => 'SIGNALP_CELLO_TMPRED',
526  #                       'IPR'    => "http://www.ebi.ac.uk/interpro/DisplayIproEntry?ac=" ,\                     'fig_id' => $fid
527  #                          '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="  
 #};  
528    
529  # if (defined $URL{$self->name}) {      foreach my $attr_ref (@$attributes_ref){
530  #     $url = $URL{$self->name}.$self->acc;  #    foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) {
531  #     return $url;          my $key = @$attr_ref[1];
532  # }          next if (($key !~ /SignalP/) && ($key !~ /CELLO/) && ($key !~ /TMPRED/));
533  # else          my @parts = split("::",$key);
534       return undef;          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  =head3 get_display_method (internal)      push (@{$datasets_ref} ,$dataset);
560    
561    }
562    
563  get_display_method() return a valid URL or undef for any observation.  =head3 get_pdb_observations() (internal)
564    
565  URLs are constructed by looking at the Accession acc()  and  name()  This methods sets the type and class for pdb observations
 and Info from both attributes is combined with a table of base URLs stored in this function.  
566    
567  =cut  =cut
568    
569  sub get_display_method {  sub get_pdb_observations{
570        my ($fid,$datasets_ref, $attributes_ref) = (@_);
571    
572   my ($self) = @_;      my $fig = new FIG;
573    
574  # a hash with a URL for each observation; identified by name()      foreach my $attr_ref (@$attributes_ref){
575  #my $URL             => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\      #foreach my $attr_ref ($fig->get_attributes($fid,'PDB')) {
 #                        'bbh'=> "http://www.theseed.org/featalign.cgi?id1="  
 # };  
576    
577  #if (defined $URL{$self->name}) {          my $key = @$attr_ref[1];
578  #     $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc;          next if ( ($key !~ /PDB/));
579  #     return $url;          my($key1,$key2) =split("::",$key);
580  # }          my $value = @$attr_ref[2];
581  # else          my ($evalue,$location) = split(";",$value);
582       return undef;  
583            if($evalue =~/(\d+)\.(\d+)/){
584                my $part2 = 1000 - $1;
585                my $part1 = $2/100;
586                $evalue = $part1."e-".$part2;
587            }
588    
589            my($start,$stop) =split("-",$location);
590    
591            my $url = @$attr_ref[3];
592            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        }
603  }  }
604    
605  =head3 get_attribute_based_evidence (internal)  =head3 get_cluster_observations() (internal)
606    
607  This method retrieves evidence from the attribute server  This methods sets the type and class for cluster observations
608    
609  =cut  =cut
610    
611  sub get_attribute_based_observations{  sub get_cluster_observations{
612        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);
620    }
621    
622    
623    =head3 get_sims_observations() (internal)
624    
625    This methods retrieves sims fills the internal data structures.
626    
627    =cut
628    
629    sub get_sims_observations{
630    
     # we read a FIG ID and a reference to an array (of arrays of hashes, see above)  
631      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
632        my $fig = new FIG;
633        my @sims= $fig->nsims($fid,500,1e-20,"all");
634        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 $_myfig = new FIG;      my %already;
648        my (@new_sims, @uniprot);
649        foreach my $sim (@sims){
650            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];
662            my $qfrom = $sim->[6];
663            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',
673                        'acc' => $hit,
674                        'identity' => $percent,
675                        'type' => 'seq',
676                        'evalue' => $evalue,
677                        'qstart' => $qfrom,
678                        '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      foreach my $attr_ref ($_myfig->get_attributes($fid)) {          push (@{$datasets_ref} ,$dataset);
690        }
691    }
692    
693          # convert the ref into a string for easier handling  =head3 get_database (internal)
694          my ($string) = "@$attr_ref";  This method gets the database association from the sequence id
695    
696  #       print "S:$string\n";  =cut
         my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/);  
697    
698          # THIS SHOULD BE DONE ANOTHER WAY FM->TD  sub get_database{
699          # we need to do the right thing for each type, ie no evalue for CELLO and no coordinates, but a score, etc      my ($id) = (@_);
         # as fas as possible this should be configured so that the type of observation and the regexp are  
         # stored somewhere for easy expansion  
         #  
700    
701          if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) {      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              # some keys are composite CDD::1233244 or PFAM:PF1233      return ($db);
715    
             if ( $key =~ /::/ ) {  
                 my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/);  
                 $val=$restkey.";".$val;  
                 $key=$firstkey;  
716              }              }
717    
             my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ );  
718    
719              my $evalue= 255;  =head3 get_identical_proteins() (internal)
             if (defined $raw_evalue) { # some of the tool do not give us an evalue  
720    
721                  my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/);  This methods retrieves sims fills the internal data structures.
                 my ($new_k, $new_exp);  
722    
723                  #  =cut
724                  #  THIS DOES NOT WORK PROPERLY  
725                  #  sub get_identical_proteins{
                 if($raw_evalue =~/(\d+).(\d+)/){  
726    
727  #                   $new_exp = (1000+$expo);      my ($fid,$datasets_ref) = (@_);
728          #           $new_k = $k / 100;      my $fig = new FIG;
729        my $funcs_ref;
730    
731        my %id_list;
732        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) {
739            my ($tmp, $who);
740            if (($id ne $fid) && ($tmp = $fig->function_of($id)) && (! defined ($id_list{$id}))) {
741                $who = &get_database($id);
742                push(@$funcs_ref, [$id,$who,$tmp]);
743                  }                  }
                 $evalue = "0.01"#new_k."e-".$new_exp;  
744              }              }
745    
746              # unroll it all into an array of hashes      my ($dataset);
747              # this needs to be done differently for different types of observations      my $dataset = {'class' => 'IDENTICAL',
748              my $dataset = [ { name => 'class', value => $key },                     'type' => 'seq',
749                              { name => 'acc' , value => $acc},                     'fig_id' => $fid,
750                              { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD                     'rows' => $funcs_ref
751                              { name => 'evalue', value => $evalue },                     };
                             { name => 'start', value => $from},  
                             { name => 'stop' , value => $to}  
                             ];  
752    
753              push (@{$datasets_ref} ,$dataset);              push (@{$datasets_ref} ,$dataset);
754          }  
755      }  
756  }  }
757    
758  =head3 get_sims_and_bbhs() (internal)  =head3 get_functional_coupling() (internal)
759    
760  This methods retrieves sims and also BBHs and fills the internal data structures.  This methods retrieves the functional coupling of a protein given a peg ID
761    
762  =cut  =cut
763    
764  #     sub get_sims_and_bbhs{  sub get_functional_coupling{
765    
766  #       # blast m8 output format      my ($fid,$datasets_ref) = (@_);
767  #       # id1, id2, %ident, align len, mismatches, gaps, q.start, q.stop, s. start, s.stop, eval, bit      my $fig = new FIG;
768        my @funcs = ();
 #       my $Sims=();  
 #       @sims_src = $fig->sims($fid,80,500,"fig",0);  
 #       print "found $#sims_src SIMs\n";  
 #       foreach $sims (@sims_src) {  
 #           my ($sims_string) = "@$sims";  
 # #       print "$sims_string\n";  
 #           my ($rfid,$start,$stop,$eval) = ( $sims_string =~ /\S+\s+(\S+)\s+\S+\s\S+\s+(\S+)\s+(\S+)\s+  
 #                                             \S+\s+\S+\s+\S+\s+\S+\s+(\S+)+.*/);  
 # #       print "ID: $rfid, E:$eval, Start:$start stop:$stop\n";  
 #           $Sims{$rfid}{'eval'}=$eval;  
 #           $Sims{$rfid}{'start'}=$start;  
 #           $Sims{$rfid}{'stop'}=$stop;  
 #           print "$rfid $Sims{$rfid}{'eval'}\n";  
 #       }  
   
 #       # BBHs  
 #       my $BBHs=();  
   
 #       @bbhs_src = $fig->bbhs($fid,1.0e-10);  
 #       print "found $#bbhs_src BBHs\n";  
 #       foreach $bbh (@bbhs_src) {  
 #           #print "@$bbh\n";  
 #           my ($bbh_string) = "@$bbh";  
 #           my ($rfid,$eval,$score) = ( $bbh_string =~ /(\S+)\s(\S+)\s(\S+)/);  
 #           #print "ID: $rfid, E:$eval, S:$score\n";  
 #           $BBHs{$rfid}{'eval'}=$eval;  
 #           $BBHs{$rfid}{'score'}=$score;  
 # #print "$rfid $BBHs{$rfid}{'eval'}\n";  
 #       }  
769    
770  #     }      # initialize some variables
771        my($sc,$neigh);
772    
773        # set default parameters for coupling and evidence
774        my ($bound,$sim_cutoff,$coupling_cutoff) = (5000, 1.0e-10, 4);
775    
776        # get the fc data
777        my @fc_data = $fig->coupling_and_evidence($fid,$bound,$sim_cutoff,$coupling_cutoff,1);
778    
779        # retrieve data
780        my @rows = map { ($sc,$neigh) = @$_;
781                         [$sc,$neigh,scalar $fig->function_of($neigh)]
782                      } @fc_data;
783    
784        my ($dataset);
785        my $dataset = {'class' => 'PCH',
786                       'type' => 'fc',
787                       'fig_id' => $fid,
788                       'rows' => \@rows
789                       };
790    
791        push (@{$datasets_ref} ,$dataset);
792    
793    }
794    
795  =head3 new (internal)  =head3 new (internal)
796    
# Line 539  Line 799 
799  =cut  =cut
800    
801  sub new {  sub new {
802    my ($self) = @_;    my ($class,$dataset) = @_;
803    
804    $self = { acc => '',    my $self = { class => $dataset->{'class'},
805              description => '',                 type => $dataset->{'type'},
806              class => '',                 fig_id => $dataset->{'fig_id'},
807              type => '',                 score => $dataset->{'score'},
             start => '',  
             stop => '',  
             evalue => '',  
             score => '',  
             display_method => '',  
             feature_id => '',  
             rank => '',  
             supports_annotation => ''  
808            };            };
809    
810    bless($self, 'Observation');    bless($self,$class);
811    
812    return $self;    return $self;
813  }  }
814    
815    =head3 identity (internal)
816    
817    Returns the % identity of the similar sequence
818    
819    =cut
820    
821    sub identity {
822        my ($self) = @_;
823    
824        return $self->{identity};
825    }
826    
827    =head3 fig_id (internal)
828    
829    =cut
830    
831    sub fig_id {
832      my ($self) = @_;
833      return $self->{fig_id};
834    }
835    
836  =head3 feature_id (internal)  =head3 feature_id (internal)
837    
 Returns the ID  of the feature these Observations belong to.  
838    
839  =cut  =cut
840    
# Line 571  Line 843 
843    
844    return $self->{feature_id};    return $self->{feature_id};
845  }  }
846    
847    =head3 id (internal)
848    
849    Returns the ID  of the identical sequence
850    
851    =cut
852    
853    sub id {
854        my ($self) = @_;
855    
856        return $self->{id};
857    }
858    
859    =head3 organism (internal)
860    
861    Returns the organism  of the identical sequence
862    
863    =cut
864    
865    sub organism {
866        my ($self) = @_;
867    
868        return $self->{organism};
869    }
870    
871    =head3 function (internal)
872    
873    Returns the function of the identical sequence
874    
875    =cut
876    
877    sub function {
878        my ($self) = @_;
879    
880        return $self->{function};
881    }
882    
883    =head3 database (internal)
884    
885    Returns the database of the identical sequence
886    
887    =cut
888    
889    sub database {
890        my ($self) = @_;
891    
892        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;
1028    
1029    use base qw(Observation);
1030    
1031    sub new {
1032    
1033        my ($class,$dataset) = @_;
1034        my $self = $class->SUPER::new($dataset);
1035        $self->{rows} = $dataset->{'rows'};
1036    
1037        bless($self,$class);
1038        return $self;
1039    }
1040    
1041    =head3 display_table()
1042    
1043    If available use the function specified here to display the "raw" observation.
1044    This code will display a table for the identical protein
1045    
1046    
1047    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
1048    dence.
1049    
1050    =cut
1051    
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 = [];
1061        my $count_identical = 0;
1062        my $content;
1063        foreach my $row (@$rows) {
1064            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 = [];
1069            push(@$single_domain,$who);
1070            push(@$single_domain,&HTML::set_prot_links($cgi,$id));
1071            push(@$single_domain,$organism);
1072            push(@$single_domain,$assignment);
1073            push(@$all_domains,$single_domain);
1074            $count_identical++;
1075        }
1076    
1077        if ($count_identical >0){
1078            $content = $all_domains;
1079        }
1080        else{
1081            $content = "<p>This PEG does not have any essentially identical proteins</p>";
1082        }
1083        return ($content);
1084    }
1085    
1086    1;
1087    
1088    #########################################
1089    #########################################
1090    package Observation::FC;
1091    1;
1092    
1093    use base qw(Observation);
1094    
1095    sub new {
1096    
1097        my ($class,$dataset) = @_;
1098        my $self = $class->SUPER::new($dataset);
1099        $self->{rows} = $dataset->{'rows'};
1100    
1101        bless($self,$class);
1102        return $self;
1103    }
1104    
1105    =head3 display_table()
1106    
1107    If available use the function specified here to display the "raw" observation.
1108    This code will display a table for the identical protein
1109    
1110    
1111    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
1112    dence.
1113    
1114    =cut
1115    
1116    sub display_table {
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 = [];
1123        my $count = 0;
1124        my $content;
1125    
1126        foreach my $row (@$rows) {
1127            my $single_domain = [];
1128            $count++;
1129    
1130            # construct the score link
1131            my $score = $row->[0];
1132            my $toid = $row->[1];
1133            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>";
1135    
1136            push(@$single_domain,$sc_link);
1137            push(@$single_domain,$row->[1]);
1138            push(@$single_domain,$row->[2]);
1139            push(@$functional_data,$single_domain);
1140        }
1141    
1142        if ($count >0){
1143            $content = $functional_data;
1144        }
1145        else
1146        {
1147            $content = "<p>This PEG does not have any functional coupling</p>";
1148        }
1149        return ($content);
1150    }
1151    
1152    
1153    #########################################
1154    #########################################
1155    package Observation::Domain;
1156    
1157    use base qw(Observation);
1158    
1159    sub new {
1160    
1161        my ($class,$dataset) = @_;
1162        my $self = $class->SUPER::new($dataset);
1163        $self->{evalue} = $dataset->{'evalue'};
1164        $self->{acc} = $dataset->{'acc'};
1165        $self->{start} = $dataset->{'start'};
1166        $self->{stop} = $dataset->{'stop'};
1167    
1168        bless($self,$class);
1169        return $self;
1170    }
1171    
1172    sub display {
1173        my ($thing,$gd) = @_;
1174        my $lines = [];
1175    #    my $line_config = { 'title' => $thing->acc,
1176    #                       'short_title' => $thing->type,
1177    #                       'basepair_offset' => '1' };
1178        my $color = "4";
1179    
1180        my $line_data = [];
1181        my $links_list = [];
1182        my $descriptions = [];
1183    
1184        my $db_and_id = $thing->acc;
1185        my ($db,$id) = split("::",$db_and_id);
1186    
1187        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;
1222        $score = {"title" => "score",
1223                  "value" => $thing->evalue};
1224        push(@$descriptions,$score);
1225    
1226        my $link_id;
1227        if ($thing->acc =~/\w+::(\d+)/){
1228            $link_id = $1;
1229        }
1230    
1231        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,
1238                 "link" => $link_url};
1239        push(@$links_list,$link);
1240    
1241        my $element_hash = {
1242            "title" => $thing->type,
1243            "start" => $thing->start,
1244            "end" =>  $thing->stop,
1245            "color"=> $color,
1246            "zlayer" => '2',
1247            "links_list" => $links_list,
1248            "description" => $descriptions};
1249    
1250        push(@$line_data,$element_hash);
1251        $gd->add_line($line_data, $line_config);
1252    
1253        return $gd;
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;
1501    
1502    use base qw(Observation);
1503    
1504    sub new {
1505    
1506        my ($class,$dataset) = @_;
1507        my $self = $class->SUPER::new($dataset);
1508        $self->{identity} = $dataset->{'identity'};
1509        $self->{acc} = $dataset->{'acc'};
1510        $self->{evalue} = $dataset->{'evalue'};
1511        $self->{qstart} = $dataset->{'qstart'};
1512        $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);
1522        return $self;
1523    }
1524    
1525    =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.
1637    This code will display a table for the similarities protein
1638    
1639    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.
1640    
1641    =cut
1642    
1643    sub display_table {
1644        my ($self,$dataset, $preference, $columns) = @_;
1645    
1646        my $data = [];
1647        my $count = 0;
1648        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        my (%box_column, %subsystems_column, %evidence_column, %code_attributes);
1658        foreach my $col (@$columns){
1659            # get the column for the subsystems
1660            if ($col eq "subsystem"){
1661                %subsystems_column = &get_subsystems_column(\@ids);
1662            }
1663            # get the column for the evidence codes
1664            elsif ($col eq "evidence"){
1665                %evidence_column = &get_evidence_column(\@ids);
1666            }
1667        }
1668    
1669        foreach my $thing (@$dataset) {
1670            next if ($thing->class ne "SIM");
1671            my $single_domain = [];
1672            $count++;
1673    
1674            my $id = $thing->acc;
1675    
1676            my $iden    = $thing->identity;
1677            my $ln1     = $thing->qlength;
1678            my $ln2     = $thing->hlength;
1679            my $b1      = $thing->qstart;
1680            my $e1      = $thing->qstop;
1681            my $b2      = $thing->hstart;
1682            my $e2      = $thing->hstop;
1683            my $d1      = abs($e1 - $b1) + 1;
1684            my $d2      = abs($e2 - $b2) + 1;
1685            my $reg1    = "$b1-$e1 (<b>$d1/$ln1</b>)";
1686            my $reg2    = "$b2-$e2 (<b>$d2/$ln2</b>)";
1687    
1688            # checkbox column
1689            my $field_name = "tables_" . $id;
1690            my $pair_name = "visual_" . $id;
1691            my $box_col = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
1692    
1693            my $prefer_id = &get_prefer($thing->acc, $preference);
1694            my $acc_col .= &HTML::set_prot_links($cgi,$prefer_id);
1695            my $db = $thing->database;
1696            if ($preference ne "FIG"){
1697                $db = &Observation::get_database($prefer_id);
1698            }
1699    
1700            push(@$single_domain,$box_col);                        # permanent column
1701            push(@$single_domain,$acc_col);                        # permanent column
1702            push(@$single_domain,$thing->evalue);                  # permanent column
1703            push(@$single_domain,"$iden\%");                       # permanent column
1704            push(@$single_domain,$reg1);                           # permanent column
1705            push(@$single_domain,$reg2);                           # permanent column
1706            push(@$single_domain,$thing->organism);                # permanent column
1707            push(@$single_domain,$thing->function);                # permanent column
1708            push(@$single_domain,$subsystems_column{$id}) if (grep (/subsystem/, @$columns));
1709            push(@$single_domain,$evidence_column{$id}) if (grep (/evidence/, @$columns));
1710            push(@$data,$single_domain);
1711        }
1712    
1713        if ($count >0 ){
1714            $content = $data;
1715        }
1716        else{
1717            $content = "<p>This PEG does not have any similarities</p>";
1718        }
1719        return ($content);
1720    }
1721    
1722    sub get_box_column{
1723        my ($ids) = @_;
1724        my %column;
1725        foreach my $id (@$ids){
1726            my $field_name = "tables_" . $id;
1727            my $pair_name = "visual_" . $id;
1728            $column{$id} = qq(<input type=checkbox name=seq value="$id" id="$field_name" onClick="VisualCheckPair('$field_name', '$pair_name');">);
1729        }
1730        return (%column);
1731    }
1732    
1733    sub get_subsystems_column{
1734        my ($ids) = @_;
1735    
1736        my $fig = new FIG;
1737        my $cgi = new CGI;
1738        my %in_subs  = $fig->subsystems_for_pegs($ids);
1739        my %column;
1740        foreach my $id (@$ids){
1741            my @in_sub = $in_subs{$id} if (defined $in_subs{$id});
1742            my $in_sub;
1743    
1744            if (@in_sub > 0) {
1745                $in_sub = @in_sub;
1746    
1747                # RAE: add a javascript popup with all the subsystems
1748                my $ss_list=join "<br>", map { my $g = $_; $g =~ s/\_/ /g; $_ = $g } sort {$a cmp $b} @in_sub;
1749                $column{$id} = $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);
1750            } else {
1751                $column{$id} = "&nbsp;";
1752            }
1753        }
1754        return (%column);
1755    }
1756    
1757    sub get_evidence_column{
1758        my ($ids) = @_;
1759        my $fig = new FIG;
1760        my $cgi = new CGI;
1761        my (%column, %code_attributes);
1762    
1763        my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($ids);
1764        foreach my $key (@codes){
1765            push (@{$code_attributes{$$key[0]}}, $key);
1766        }
1767    
1768        foreach my $id (@$ids){
1769            # add evidence code with tool tip
1770            my $ev_codes=" &nbsp; ";
1771            my @ev_codes = "";
1772    
1773            if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) {
1774                my @codes;
1775                @codes = @{$code_attributes{$id}} if (defined @{$code_attributes{$id}});
1776                @ev_codes = ();
1777                foreach my $code (@codes) {
1778                    my $pretty_code = $code->[2];
1779                    if ($pretty_code =~ /;/) {
1780                        my ($cd, $ss) = split(";", $code->[2]);
1781                        $ss =~ s/_/ /g;
1782                        $pretty_code = $cd;# . " in " . $ss;
1783                    }
1784                    push(@ev_codes, $pretty_code);
1785                }
1786            }
1787    
1788            if (scalar(@ev_codes) && $ev_codes[0]) {
1789                my $ev_code_help=join("<br />", map {&HTML::evidence_codes_explain($_)} @ev_codes);
1790                $ev_codes = $cgi->a(
1791                                    {
1792                                        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));
1793            }
1794            $column{$id}=$ev_codes;
1795        }
1796        return (%column);
1797    }
1798    
1799    sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
1800    
1801    sub get_prefer {
1802        my ($fid, $db) = @_;
1803        my $fig = new FIG;
1804    
1805        my @aliases = $fig->feature_aliases($fid);
1806    
1807        foreach my $alias (@aliases){
1808            my $id_db = &Observation::get_database($alias);
1809            if ($id_db eq $db){
1810                return ($alias);
1811            }
1812        }
1813        return ($fid);
1814    }
1815    
1816    sub color {
1817        my ($evalue) = @_;
1818    
1819        my $color;
1820        if ($evalue <= 1e-170){
1821            $color = 51;
1822        }
1823        elsif (($evalue <= 1e-120) && ($evalue > 1e-170)){
1824            $color = 52;
1825        }
1826        elsif (($evalue <= 1e-90) && ($evalue > 1e-120)){
1827            $color = 53;
1828        }
1829        elsif (($evalue <= 1e-70) && ($evalue > 1e-90)){
1830            $color = 54;
1831        }
1832        elsif (($evalue <= 1e-40) && ($evalue > 1e-70)){
1833            $color = 55;
1834        }
1835        elsif (($evalue <= 1e-20) && ($evalue > 1e-40)){
1836            $color = 56;
1837        }
1838        elsif (($evalue <= 1e-5) && ($evalue > 1e-20)){
1839            $color = 57;
1840        }
1841        elsif (($evalue <= 1) && ($evalue > 1e-5)){
1842            $color = 58;
1843        }
1844        elsif (($evalue <= 10) && ($evalue > 1)){
1845            $color = 59;
1846        }
1847        else{
1848            $color = 60;
1849        }
1850    
1851    
1852        return ($color);
1853    }
1854    
1855    
1856    ############################
1857    package Observation::Cluster;
1858    
1859    use base qw(Observation);
1860    
1861    sub new {
1862    
1863        my ($class,$dataset) = @_;
1864        my $self = $class->SUPER::new($dataset);
1865        $self->{context} = $dataset->{'context'};
1866        bless($self,$class);
1867        return $self;
1868    }
1869    
1870    sub display {
1871        my ($self,$gd) = @_;
1872    
1873        my $fid = $self->fig_id;
1874        my $compare_or_coupling = $self->context;
1875        my $gd_window_size = $gd->window_size;
1876        my $fig = new FIG;
1877        my $all_regions = [];
1878    
1879        #get the organism genome
1880        my $target_genome = $fig->genome_of($fid);
1881    
1882        # get location of the gene
1883        my $data = $fig->feature_location($fid);
1884        my ($contig, $beg, $end);
1885        my %reverse_flag;
1886    
1887        if ($data =~ /(.*)_(\d+)_(\d+)$/){
1888            $contig = $1;
1889            $beg = $2;
1890            $end = $3;
1891        }
1892    
1893        my $offset;
1894        my ($region_start, $region_end);
1895        if ($beg < $end)
1896        {
1897            $region_start = $beg - 4000;
1898            $region_end = $end+4000;
1899            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
1900        }
1901        else
1902        {
1903            $region_start = $end-4000;
1904            $region_end = $beg+4000;
1905            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
1906            $reverse_flag{$target_genome} = $fid;
1907        }
1908    
1909        # call genes in region
1910        my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_end);
1911        push(@$all_regions,$target_gene_features);
1912        my (@start_array_region);
1913        push (@start_array_region, $offset);
1914    
1915        my %all_genes;
1916        my %all_genomes;
1917        foreach my $feature (@$target_gene_features){ $all_genes{$feature} = $fid;}
1918    
1919        if ($compare_or_coupling eq "diverse")
1920        {
1921            my @coup = grep { $_->[1]} $fig->coupling_and_evidence($fid,5000,1e-10,4,1);
1922    
1923            my $coup_count = 0;
1924    
1925            foreach my $pair (@{$coup[0]->[2]}) {
1926                #   last if ($coup_count > 10);
1927                my ($peg1,$peg2) = @$pair;
1928    
1929                my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome);
1930                $pair_genome = $fig->genome_of($peg1);
1931    
1932                my $location = $fig->feature_location($peg1);
1933                if($location =~/(.*)_(\d+)_(\d+)$/){
1934                    $pair_contig = $1;
1935                    $pair_beg = $2;
1936                    $pair_end = $3;
1937                    if ($pair_beg < $pair_end)
1938                    {
1939                        $pair_region_start = $pair_beg - 4000;
1940                        $pair_region_stop = $pair_end+4000;
1941                        $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
1942                    }
1943                    else
1944                    {
1945                        $pair_region_start = $pair_end-4000;
1946                        $pair_region_stop = $pair_beg+4000;
1947                        $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
1948                        $reverse_flag{$pair_genome} = $peg1;
1949                    }
1950    
1951                    push (@start_array_region, $offset);
1952    
1953                    $all_genomes{$pair_genome} = 1;
1954                    my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop);
1955                    push(@$all_regions,$pair_features);
1956                    foreach my $pair_feature (@$pair_features){ $all_genes{$pair_feature} = $peg1;}
1957                }
1958                $coup_count++;
1959            }
1960        }
1961    
1962        elsif ($compare_or_coupling eq "close")
1963        {
1964            # make a hash of genomes that are phylogenetically close
1965            #my $close_threshold = ".26";
1966            #my @genomes = $fig->genomes('complete');
1967            #my %close_genomes = ();
1968            #foreach my $compared_genome (@genomes)
1969            #{
1970            #    my $dist = $fig->crude_estimate_of_distance($target_genome,$compared_genome);
1971            #    #$close_genomes{$compared_genome} = $dist;
1972            #    if ($dist <= $close_threshold)
1973            #    {
1974            #       $all_genomes{$compared_genome} = 1;
1975            #    }
1976            #}
1977            $all_genomes{"216592.1"} = 1;
1978            $all_genomes{"79967.1"} = 1;
1979            $all_genomes{"199310.1"} = 1;
1980            $all_genomes{"216593.1"} = 1;
1981            $all_genomes{"155864.1"} = 1;
1982            $all_genomes{"83334.1"} = 1;
1983            $all_genomes{"316407.3"} = 1;
1984    
1985            foreach my $comp_genome (keys %all_genomes){
1986                my $return = $fig->bbh_list($comp_genome,[$fid]);
1987                my $feature_list = $return->{$fid};
1988                foreach my $peg1 (@$feature_list){
1989                    my $location = $fig->feature_location($peg1);
1990                    my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome);
1991                    $pair_genome = $fig->genome_of($peg1);
1992    
1993                    if($location =~/(.*)_(\d+)_(\d+)$/){
1994                        $pair_contig = $1;
1995                        $pair_beg = $2;
1996                        $pair_end = $3;
1997                        if ($pair_beg < $pair_end)
1998                        {
1999                            $pair_region_start = $pair_beg - 4000;
2000                            $pair_region_stop = $pair_end + 4000;
2001                            $offset = ($2+(($3-$2)/2))-($gd_window_size/2);
2002                        }
2003                        else
2004                        {
2005                            $pair_region_start = $pair_end-4000;
2006                            $pair_region_stop = $pair_beg+4000;
2007                            $offset = ($3+(($2-$3)/2))-($gd_window_size/2);
2008                            $reverse_flag{$pair_genome} = $peg1;
2009                        }
2010    
2011                        push (@start_array_region, $offset);
2012                        $all_genomes{$pair_genome} = 1;
2013                        my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop);
2014                        push(@$all_regions,$pair_features);
2015                        foreach my $pair_feature (@$pair_features){ $all_genes{$pair_feature} = $peg1;}
2016                    }
2017                }
2018            }
2019        }
2020    
2021        # get the PCH to each of the genes
2022        my $pch_sets = [];
2023        my %pch_already;
2024        foreach my $gene_peg (keys %all_genes)
2025        {
2026            if ($pch_already{$gene_peg}){next;};
2027            my $gene_set = [$gene_peg];
2028            foreach my $pch_peg ($fig->in_pch_pin_with($gene_peg)) {
2029                $pch_peg =~ s/,.*$//;
2030                my $pch_genome = $fig->genome_of($pch_peg);
2031                if ( ($gene_peg ne $pch_peg) && ($all_genomes{$pch_genome})) {
2032                    push(@$gene_set,$pch_peg);
2033                    $pch_already{$pch_peg}=1;
2034                }
2035                $pch_already{$gene_peg}=1;
2036            }
2037            push(@$pch_sets,$gene_set);
2038        }
2039    
2040        #create a rank of the pch's
2041        my %pch_set_rank;
2042        my $order = 0;
2043        foreach my $set (@$pch_sets){
2044            my $count = scalar(@$set);
2045            $pch_set_rank{$order} = $count;
2046            $order++;
2047        }
2048    
2049        my %peg_rank;
2050        my $counter =  1;
2051        foreach my $pch_order (sort {$pch_set_rank{$b} <=> $pch_set_rank{$a}} keys %pch_set_rank){
2052            my $good_set = @$pch_sets[$pch_order];
2053            my $flag_set = 0;
2054            if (scalar (@$good_set) > 1)
2055            {
2056                foreach my $peg (@$good_set){
2057                    if ((!$peg_rank{$peg})){
2058                        $peg_rank{$peg} = $counter;
2059                        $flag_set = 1;
2060                    }
2061                }
2062                $counter++ if ($flag_set == 1);
2063            }
2064            else
2065            {
2066                foreach my $peg (@$good_set){
2067                    $peg_rank{$peg} = "20";
2068                }
2069            }
2070        }
2071    
2072    
2073    #    my $bbh_sets = [];
2074    #    my %already;
2075    #    foreach my $gene_key (keys(%all_genes)){
2076    #       if($already{$gene_key}){next;}
2077    #       my $gene_set = [$gene_key];
2078    #
2079    #       my $gene_key_genome = $fig->genome_of($gene_key);
2080    #
2081    #       foreach my $genome_key (keys(%all_genomes)){
2082    #           #next if ($gene_key_genome eq $genome_key);
2083    #           my $return = $fig->bbh_list($genome_key,[$gene_key]);
2084    #
2085    #           my $feature_list = $return->{$gene_key};
2086    #           foreach my $fl (@$feature_list){
2087    #               push(@$gene_set,$fl);
2088    #           }
2089    #       }
2090    #       $already{$gene_key} = 1;
2091    #       push(@$bbh_sets,$gene_set);
2092    #    }
2093    #
2094    #    my %bbh_set_rank;
2095    #    my $order = 0;
2096    #    foreach my $set (@$bbh_sets){
2097    #       my $count = scalar(@$set);
2098    #       $bbh_set_rank{$order} = $count;
2099    #       $order++;
2100    #    }
2101    #
2102    #    my %peg_rank;
2103    #    my $counter =  1;
2104    #    foreach my $bbh_order (sort {$bbh_set_rank{$b} <=> $bbh_set_rank{$a}} keys %bbh_set_rank){
2105    #       my $good_set = @$bbh_sets[$bbh_order];
2106    #       my $flag_set = 0;
2107    #       if (scalar (@$good_set) > 1)
2108    #       {
2109    #           foreach my $peg (@$good_set){
2110    #               if ((!$peg_rank{$peg})){
2111    #                   $peg_rank{$peg} = $counter;
2112    #                   $flag_set = 1;
2113    #               }
2114    #           }
2115    #           $counter++ if ($flag_set == 1);
2116    #       }
2117    #       else
2118    #       {
2119    #           foreach my $peg (@$good_set){
2120    #               $peg_rank{$peg} = "20";
2121    #           }
2122    #       }
2123    #    }
2124    
2125        foreach my $region (@$all_regions){
2126            my $sample_peg = @$region[0];
2127            my $region_genome = $fig->genome_of($sample_peg);
2128            my $region_gs = $fig->genus_species($region_genome);
2129            my $abbrev_name = $fig->abbrev($region_gs);
2130            my $line_config = { 'title' => $region_gs,
2131                                'short_title' => $abbrev_name,
2132                                'basepair_offset' => '0'
2133                                };
2134    
2135            my $offsetting = shift @start_array_region;
2136    
2137            my $second_line_config = { 'title' => "$region_gs",
2138                                       'short_title' => "",
2139                                       'basepair_offset' => '0'
2140                                       };
2141    
2142            my $line_data = [];
2143            my $second_line_data = [];
2144    
2145            # initialize variables to check for overlap in genes
2146            my ($prev_start, $prev_stop, $prev_fig, $second_line_flag);
2147            my $major_line_flag = 0;
2148            my $prev_second_flag = 0;
2149    
2150            foreach my $fid1 (@$region){
2151                $second_line_flag = 0;
2152                my $element_hash;
2153                my $links_list = [];
2154                my $descriptions = [];
2155    
2156                my $color = $peg_rank{$fid1};
2157    
2158                # get subsystem information
2159                my $function = $fig->function_of($fid1);
2160                my $url_link = "http://seed-viewer.theseed.org/index.cgi?action=ShowAnnotation&prot=".$fid1;
2161    
2162                my $link;
2163                $link = {"link_title" => $fid1,
2164                         "link" => $url_link};
2165                push(@$links_list,$link);
2166    
2167                my @subsystems = $fig->peg_to_subsystems($fid1);
2168                foreach my $subsystem (@subsystems){
2169                    my $link;
2170                    $link = {"link" => "http://seed-viewer.theseed.org/index.cgi?action=ShowSubsystem&subsystem_name=$subsystem",
2171                             "link_title" => $subsystem};
2172                    push(@$links_list,$link);
2173                }
2174    
2175                my $description_function;
2176                $description_function = {"title" => "function",
2177                                         "value" => $function};
2178                push(@$descriptions,$description_function);
2179    
2180                my $description_ss;
2181                my $ss_string = join (",", @subsystems);
2182                $description_ss = {"title" => "subsystems",
2183                                   "value" => $ss_string};
2184                push(@$descriptions,$description_ss);
2185    
2186    
2187                my $fid_location = $fig->feature_location($fid1);
2188                if($fid_location =~/(.*)_(\d+)_(\d+)$/){
2189                    my($start,$stop);
2190                    $start = $2 - $offsetting;
2191                    $stop = $3 - $offsetting;
2192    
2193                    if ( (($prev_start) && ($prev_stop) ) &&
2194                         ( ($start < $prev_start) || ($start < $prev_stop) ||
2195                           ($stop < $prev_start) || ($stop < $prev_stop) )){
2196                        if (($second_line_flag == 0) && ($prev_second_flag == 0)) {
2197                            $second_line_flag = 1;
2198                            $major_line_flag = 1;
2199                        }
2200                    }
2201                    $prev_start = $start;
2202                    $prev_stop = $stop;
2203                    $prev_fig = $fid1;
2204    
2205                    if ((defined($reverse_flag{$region_genome})) && ($reverse_flag{$region_genome} eq $all_genes{$fid1})){
2206                        $start = $gd_window_size - $start;
2207                        $stop = $gd_window_size - $stop;
2208                    }
2209    
2210                    $element_hash = {
2211                        "title" => $fid1,
2212                        "start" => $start,
2213                        "end" =>  $stop,
2214                        "type"=> 'arrow',
2215                        "color"=> $color,
2216                        "zlayer" => "2",
2217                        "links_list" => $links_list,
2218                        "description" => $descriptions
2219                    };
2220    
2221                    # if there is an overlap, put into second line
2222                    if ($second_line_flag == 1){ push(@$second_line_data,$element_hash); $prev_second_flag = 1;}
2223                    else{ push(@$line_data,$element_hash); $prev_second_flag = 0;}
2224    
2225                }
2226            }
2227            $gd->add_line($line_data, $line_config);
2228            $gd->add_line($second_line_data, $second_line_config) if ($major_line_flag == 1);
2229        }
2230        return $gd;
2231    }
2232    
2233    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3