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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3