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

Diff of /FigKernelPackages/Observation.pm

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

revision 1.8, Tue Jun 19 22:11:25 2007 UTC revision 1.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 Table;  use HTML;
13    
14  1;  1;
15    
# Line 22  Line 26 
26    
27  The data can be used to display information for a given sequence feature (protein or other, but primarily information is computed for proteins).  The data can be used to display information for a given sequence feature (protein or other, but primarily information is computed for proteins).
28    
 Example:  
   
 use FIG;  
 use Observation;  
   
 my $fig = new FIG;  
 my $fid = "fig|83333.1.peg.3";  
   
 my $observations = Observation::get_objects($fid);  
 foreach my $observation (@$observations) {  
     print "ID: " . $fid . "\n";  
     print "Start: " . $observation->start() . "\n";  
     ...  
 }  
   
 B<return an array of objects>  
   
   
 print "$Observation->acc\n" prints the Accession number if present for the Observation  
   
29  =cut  =cut
30    
31  =head1 BACKGROUND  =head1 BACKGROUND
# Line 65  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->{description};    return $self->{rows};
75    }
76    
77    =head3 acc()
78    
79    A valid accession or remote ID (in the style of a db_xref) or a valid local ID (FID) in case this is supported.
80    
81    =cut
82    
83    sub acc {
84      my ($self) = @_;
85      return $self->{acc};
86  }  }
87    
88  =head3 class()  =head3 class()
# Line 101  Line 94 
94    
95  =over 9  =over 9
96    
97    =item IDENTICAL (seq)
98    
99  =item SIM (seq)  =item SIM (seq)
100    
101  =item BBH (seq)  =item BBH (seq)
# Line 115  Line 110 
110    
111  =item PFAM (dom)  =item PFAM (dom)
112    
113  =item SIGNALP (dom)  =item SIGNALP_CELLO_TMPRED (loc)
114    
115  =item  CELLO(loc)  =item PDB (seq)
116    
117  =item TMHMM (loc)  =item TMHMM (loc)
118    
# Line 156  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 183  Line 178 
178    return $self->{stop};    return $self->{stop};
179  }  }
180    
181  =head3 evalue()  =head3 start()
182    
183  E-value or P-Value if present.  Start of hit in query sequence.
184    
185  =cut  =cut
186    
187  sub evalue {  sub qstart {
188    my ($self) = @_;    my ($self) = @_;
189    
190    return $self->{evalue};      return $self->{qstart};
191  }  }
192    
193  =head3 score()  =head3 qstop()
   
 Score if present.  
194    
195  B<Please note: >  End of the hit in query sequence.
 Either score or eval are required.  
196    
197  =cut  =cut
198    
199  sub score {  sub qstop {
200    my ($self) = @_;    my ($self) = @_;
201    return $self->{score};  
202        return $self->{qstop};
203  }  }
204    
205    =head3 hstart()
206    
207  =head3 display_method()  Start of hit in hit sequence.
208    
209  If available use the function specified here to display the "raw" observation.  =cut
 In the case of a BLAST alignment of fid1 and fid2 a cgi script  
 will be called to display the results of running the command "bl2seq fid1 fid2".  
210    
211  B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evidence.  sub hstart {
212        my ($self) = @_;
213    
214  =cut      return $self->{hstart};
215    }
216    
217  sub display {  =head3 end()
218    
219    die "Abstract Method Called\n";  End of the hit in hit sequence.
220    
221  }  =cut
222    
223    sub hstop {
224        my ($self) = @_;
225    
226  =head3 rank()      return $self->{hstop};
227    }
228    
229  Returns an integer from 1 - 10 indicating the importance of this observations.  =head3 qlength()
230    
231  Currently always returns 1.  length of the query sequence in similarities
232    
233  =cut  =cut
234    
235  sub rank {  sub qlength {
236    my ($self) = @_;    my ($self) = @_;
237    
238  #  return $self->{rank};      return $self->{qlength};
   
   return 1;  
239  }  }
240    
241  =head3 supports_annotation()  =head3 hlength()
242    
243  Does a this observation support the annotation of its feature?  length of the hit sequence in similarities
244    
245  Returns  =cut
   
 =over 3  
246    
247  =item 10, if feature annotation is identical to $self->description  sub hlength {
248        my ($self) = @_;
249    
250  =item 1, Feature annotation is similar to $self->annotation; this is computed using FIG::SameFunc()      return $self->{hlength};
251    }
252    
253  =item undef  =head3 evalue()
254    
255  =back  E-value or P-Value if present.
256    
257  =cut  =cut
258    
259  sub supports_annotation {  sub evalue {
260    my ($self) = @_;    my ($self) = @_;
261    
262    # no code here so far    return $self->{evalue};
   
   return $self->{supports_annotation};  
263  }  }
264    
265  =head3 url()  =head3 score()
266    
267  URL describing the subject. In case of a BLAST hit against a sequence, this URL will lead to a page displaying the sequence record for the sequence. In case of an HMM hit, the URL will be to the URL description.  Score if present.
268    
269  =cut  =cut
270    
271  sub url {  sub score {
272    my ($self) = @_;    my ($self) = @_;
273      return $self->{score};
274    }
275    
276    =head3 display()
277    
278    my $url = get_url($self->type, $self->acc);  will be different for each type
279    
280    =cut
281    
282    sub display {
283    
284      die "Abstract Method Called\n";
285    
   return $url;  
286  }  }
287    
288  =head3 get_objects()  =head3 display_table()
289    
290  This is the B<REAL WORKHORSE> method of this Package.  will be different for each type
291    
292  It will probably have to:  =cut
293    
294    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 $dataset  
      [  
        [ { name => 'acc', value => '1234' },  
         { name => 'from', value => '4' },  
         { name => 'to', value => '400' },  
         ....  
        ],  
        [ { name => 'acc', value => '456' },  
         { name => 'from', value => '1' },  
         { name => 'to', value => '100' },  
         ....  
        ],  
        ...  
      ];  
    return $datasets;  
298   }   }
299    
300  It will invoke the required calls to the SEED API to retrieve the information required.  =head3 get_objects()
301    
302    This is the B<REAL WORKHORSE> method of this Package.
303    
304  =cut  =cut
305    
306  sub get_objects {  sub get_objects {
307      my ($self,$fid,$classes) = @_;      my ($self,$fid,$scope) = @_;
   
308    
309      my $objects = [];      my $objects = [];
310      my @matched_datasets=();      my @matched_datasets=();
311        my $fig = new FIG;
312    
313      # call function that fetches attribute based observations      # call function that fetches attribute based observations
314      # returns an array of arrays of hashes      # returns an array of arrays of hashes
315    
316      if(scalar(@$classes) < 1){      if($scope){
317          get_attribute_based_observations($fid,\@matched_datasets);          get_cluster_observations($fid,\@matched_datasets,$scope);
         get_sims_observations($fid,\@matched_datasets);  
         get_identical_proteins($fid,\@matched_datasets);  
         get_functional_coupling($fid,\@matched_datasets);  
318      }      }
319      else{      else{
         #IPR,CDD,CELLO,PFAM,SIGNALP - attribute based  
320          my %domain_classes;          my %domain_classes;
321          foreach my $class (@$classes){          my @attributes = $fig->get_attributes($fid);
322              if($class =~/(IPR|CDD|PFAM)/){          $domain_classes{'CDD'} = 1;
323                  $domain_classes{$class} = 1;          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_domain_observations($fid,\%domain_classes,\@matched_datasets);          get_attribute_based_location_observations($fid,\@matched_datasets,\@attributes);
328            get_pdb_observations($fid,\@matched_datasets,\@attributes);
         #add CELLO and SignalP later  
329      }      }
330    
331      foreach my $dataset (@matched_datasets) {      foreach my $dataset (@matched_datasets) {
# Line 352  Line 333 
333          if($dataset->{'type'} eq "dom"){          if($dataset->{'type'} eq "dom"){
334              $object = Observation::Domain->new($dataset);              $object = Observation::Domain->new($dataset);
335          }          }
336            if($dataset->{'class'} eq "PCH"){
337                $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);          push (@$objects, $object);
356      }      }
357    
# Line 359  Line 359 
359    
360  }  }
361    
362  =head1 Internal Methods  =head3 display_housekeeping
363    This method returns the housekeeping data for a given peg in a table format
 These methods are not meant to be used outside of this package.  
   
 B<Please do not use them outside of this package!>  
364    
365  =cut  =cut
366    sub display_housekeeping {
367        my ($self,$fid) = @_;
368        my $fig = new FIG;
369        my $content;
370    
371        my $org_name = $fig->org_of($fid);
372        my $org_id   = $fig->orgid_of_orgname($org_name);
373        my $loc      = $fig->feature_location($fid);
374        my($contig, $beg, $end) = $fig->boundaries_of($loc);
375        my $strand   = ($beg <= $end)? '+' : '-';
376        my @subsystems = $fig->subsystems_for_peg($fid);
377        my $function = $fig->function_of($fid);
378        my @aliases  = $fig->feature_aliases($fid);
379        my $taxonomy = $fig->taxonomy_of($org_id);
380        my @ecs = ($function =~ /\(EC\s(\d+\.[-\d+]+\.[-\d+]+\.[-\d+]+)\)/g);
381    
382  =head3 get_url (internal)      $content .= qq(<b>General Protein Data</b><br><br><br><table border="0">);
383        $content .= qq(<tr width=15%><td >FIG ID</td><td>$fid</td></tr>\n);
384  get_url() return a valid URL or undef for any observation.      $content .= qq(<tr width=15%><td >Organism Name</td><td>$org_name,&nbsp;&nbsp;$org_id</td></tr>\n);
385        $content .= qq(<tr><td width=15%>Taxonomy</td><td>$taxonomy</td></tr>\n);
386  URLs are constructed by looking at the Accession acc()  and  name()      $content .= qq(<tr width=15%><td>FIG Organism ID</td><td>$org_id</td></tr>\n);
387        $content .= qq(<tr width=15%><td>Gene Location</td><td>Contig $contig [$beg,$end], Strand $strand</td></tr>\n);;
388  Info from both attributes is combined with a table of base URLs stored in this function.      $content .= qq(<tr width=15%><td>Function</td><td>$function</td></tr>\n);
389        if ( @ecs ) {
390            $content .= qq(<tr><td>EC:</td><td>);
391            foreach my $ec ( @ecs ) {
392                my $ec_name = $fig->ec_name($ec);
393                $content .= join(" -- ", $ec, $ec_name) . "<br>\n";
394            }
395            $content .= qq(</td></tr>\n);
396        }
397    
398  =cut      if ( @subsystems ) {
399            $content .= qq(<tr><td>Subsystems</td><td>);
400            foreach my $subsystem ( @subsystems ) {
401                $content .= join(" -- ", @$subsystem) . "<br>\n";
402            }
403        }
404    
405  sub get_url {      my %groups;
406        if ( @aliases ) {
407            # get the db for each alias
408            foreach my $alias (@aliases){
409                $groups{$alias} = &get_database($alias);
410            }
411    
412   my ($self) = @_;          # group ids by aliases
413   my $url='';          my %db_aliases;
414            foreach my $key (sort {$groups{$a} cmp $groups{$b}} keys %groups){
415                push (@{$db_aliases{$groups{$key}}}, $key);
416            }
417    
 # a hash with a URL for each observation; identified by name()  
 #my $URL             => { 'PFAM' => "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?" ,\  
 #                       'IPR'    => "http://www.ebi.ac.uk/interpro/DisplayIproEntry?ac=" ,\  
 #                          'CDD' => "http://www.ncbi.nlm.nih.gov/Structure/cdd/cddsrv.cgi?uid=",\  
 #                       'PIR'    => "http://www.ncbi.nlm.nih.gov/Structure/cdd/cddsrv.cgi?uid=",\  
 #                       'FIGFAM' => '',\  
 #                          'sim'=> "http://www.theseed.org/linkin.cgi?id=",\  
 #                          'bbh'=> "http://www.theseed.org/linkin.cgi?id="  
 #};  
418    
419  # if (defined $URL{$self->name}) {          $content .= qq(<tr><td>Aliases</td><td><table border="0">);
420  #     $url = $URL{$self->name}.$self->acc;          foreach my $key (sort keys %db_aliases){
421  #     return $url;              $content .= qq(<tr><td>$key:</td><td>) . join(", ", @{$db_aliases{$key}}) . qq(</td></tr\n);
422  # }          }
423  # else          $content .= qq(</td></tr></table>\n);
      return undef;  
424  }  }
425    
426  =head3 get_display_method (internal)      $content .= qq(</table><p>\n);
427    
428  get_display_method() return a valid URL or undef for any observation.      return ($content);
429    }
430    
431  URLs are constructed by looking at the Accession acc()  and  name()  =head3 get_sims_summary
432  and Info from both attributes is combined with a table of base URLs stored in this function.  This method uses as input the similarities of a peg and creates a tree view of their taxonomy
433    
434  =cut  =cut
435    
436  sub get_display_method {  sub get_sims_summary {
437        my ($observation, $fid) = @_;
438        my $fig = new FIG;
439        my %families;
440        my @sims= $fig->nsims($fid,20000,10,"all");
441    
442   my ($self) = @_;      foreach my $sim (@sims){
443            next if ($sim->[1] !~ /fig\|/);
444            my $genome = $fig->genome_of($sim->[1]);
445            my $taxonomy = $fig->taxonomy_of($fig->genome_of($sim->[1]));
446            my $parent_tax = "Root";
447            foreach my $tax (split(/\; /, $taxonomy)){
448                push (@{$families{children}{$parent_tax}}, $tax);
449                $families{parent}{$tax} = $parent_tax;
450                $parent_tax = $tax;
451            }
452        }
453    
454  # a hash with a URL for each observation; identified by name()      foreach my $key (keys %{$families{children}}){
455  #my $URL             => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\          $families{count}{$key} = @{$families{children}{$key}};
 #                        'bbh'=> "http://www.theseed.org/featalign.cgi?id1="  
 # };  
456    
457  #if (defined $URL{$self->name}) {          my %saw;
458  #     $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc;          my @out = grep(!$saw{$_}++, @{$families{children}{$key}});
459  #     return $url;          $families{children}{$key} = \@out;
460  # }      }
461  # else      return (\%families);
      return undef;  
462  }  }
463    
464    =head1 Internal Methods
465    
466    These methods are not meant to be used outside of this package.
467    
468    B<Please do not use them outside of this package!>
469    
470    =cut
471    
472  sub get_attribute_based_domain_observations{  sub get_attribute_based_domain_observations{
473    
474      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)
475      my ($fid,$domain_classes,$datasets_ref) = (@_);      my ($fid,$domain_classes,$datasets_ref,$attributes_ref) = (@_);
476    
477      my $fig = new FIG;      my $fig = new FIG;
478    
479      foreach my $attr_ref ($fig->get_attributes($fid)) {      foreach my $attr_ref (@$attributes_ref) {
480    #    foreach my $attr_ref ($fig->get_attributes($fid)) {
481          my $key = @$attr_ref[1];          my $key = @$attr_ref[1];
482          my @parts = split("::",$key);          my @parts = split("::",$key);
483          my $class = $parts[0];          my $class = $parts[0];
# Line 461  Line 503 
503                                 'type' => "dom" ,                                 'type' => "dom" ,
504                                 'evalue' => $evalue,                                 'evalue' => $evalue,
505                                 'start' => $from,                                 'start' => $from,
506                                 'stop' => $to                                 'stop' => $to,
507                                   'fig_id' => $fid,
508                                   'score' => $raw_evalue
509                                 };                                 };
510    
511                  push (@{$datasets_ref} ,$dataset);                  push (@{$datasets_ref} ,$dataset);
# Line 470  Line 514 
514      }      }
515  }  }
516    
517  =head3 get_attribute_based_evidence (internal)  sub get_attribute_based_location_observations{
   
 This method retrieves evidence from the attribute server  
518    
519  =cut      my ($fid,$datasets_ref, $attributes_ref) = (@_);
520        my $fig = new FIG;
521    
522  sub get_attribute_based_observations{      my $location_attributes = ['SignalP','CELLO','TMPRED'];
523    
524      # we read a FIG ID and a reference to an array (of arrays of hashes, see above)      my $dataset = {'type' => "loc",
525      my ($fid,$datasets_ref) = (@_);                     'class' => 'SIGNALP_CELLO_TMPRED',
526                       'fig_id' => $fid
527                       };
528    
529      my $_myfig = new FIG;      foreach my $attr_ref (@$attributes_ref){
530    #    foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) {
531            my $key = @$attr_ref[1];
532            next if (($key !~ /SignalP/) && ($key !~ /CELLO/) && ($key !~ /TMPRED/));
533            my @parts = split("::",$key);
534            my $sub_class = $parts[0];
535            my $sub_key = $parts[1];
536            my $value = @$attr_ref[2];
537            if($sub_class eq "SignalP"){
538                if($sub_key eq "cleavage_site"){
539                    my @value_parts = split(";",$value);
540                    $dataset->{'cleavage_prob'} = $value_parts[0];
541                    $dataset->{'cleavage_loc'} = $value_parts[1];
542    #               print STDERR "LOC: $value_parts[1]";
543                }
544                elsif($sub_key eq "signal_peptide"){
545                    $dataset->{'signal_peptide_score'} = $value;
546                }
547            }
548            elsif($sub_class eq "CELLO"){
549                $dataset->{'cello_location'} = $sub_key;
550                $dataset->{'cello_score'} = $value;
551            }
552            elsif($sub_class eq "TMPRED"){
553                my @value_parts = split(/\;/,$value);
554                $dataset->{'tmpred_score'} = $value_parts[0];
555                $dataset->{'tmpred_locations'} = $value_parts[1];
556            }
557        }
558    
559      foreach my $attr_ref ($_myfig->get_attributes($fid)) {      push (@{$datasets_ref} ,$dataset);
560    
561          # convert the ref into a string for easier handling  }
         my ($string) = "@$attr_ref";  
562    
563  #       print "S:$string\n";  =head3 get_pdb_observations() (internal)
         my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/);  
564    
565          # THIS SHOULD BE DONE ANOTHER WAY FM->TD  This methods sets the type and class for pdb observations
         # we need to do the right thing for each type, ie no evalue for CELLO and no coordinates, but a score, etc  
         # as fas as possible this should be configured so that the type of observation and the regexp are  
         # stored somewhere for easy expansion  
         #  
566    
567          if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) {  =cut
568    
569              # some keys are composite CDD::1233244 or PFAM:PF1233  sub get_pdb_observations{
570        my ($fid,$datasets_ref, $attributes_ref) = (@_);
571    
572              if ( $key =~ /::/ ) {      my $fig = new FIG;
                 my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/);  
                 $val=$restkey.";".$val;  
                 $key=$firstkey;  
             }  
573    
574              my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ );      foreach my $attr_ref (@$attributes_ref){
575        #foreach my $attr_ref ($fig->get_attributes($fid,'PDB')) {
576    
577              my $evalue= 255;          my $key = @$attr_ref[1];
578              if (defined $raw_evalue) { # some of the tool do not give us an evalue          next if ( ($key !~ /PDB/));
579            my($key1,$key2) =split("::",$key);
580            my $value = @$attr_ref[2];
581            my ($evalue,$location) = split(";",$value);
582    
583                  my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/);          if($evalue =~/(\d+)\.(\d+)/){
584                  my ($new_k, $new_exp);              my $part2 = 1000 - $1;
585                my $part1 = $2/100;
586                $evalue = $part1."e-".$part2;
587            }
588    
589                  #          my($start,$stop) =split("-",$location);
                 #  THIS DOES NOT WORK PROPERLY  
                 #  
                 if($raw_evalue =~/(\d+).(\d+)/){  
590    
591  #                   $new_exp = (1000+$expo);          my $url = @$attr_ref[3];
592          #           $new_k = $k / 100;          my $dataset = {'class' => 'PDB',
593                           'type' => 'seq' ,
594                           'acc' => $key2,
595                           'evalue' => $evalue,
596                           'start' => $start,
597                           'stop' => $stop,
598                           'fig_id' => $fid
599                           };
600    
601            push (@{$datasets_ref} ,$dataset);
602                  }                  }
                 $evalue = "0.01"#new_k."e-".$new_exp;  
603              }              }
604    
605              # unroll it all into an array of hashes  =head3 get_cluster_observations() (internal)
606              # this needs to be done differently for different types of observations  
607              my $dataset = [ { name => 'class', value => $key },  This methods sets the type and class for cluster observations
608                              { name => 'acc' , value => $acc},  
609                              { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD  =cut
610                              { name => 'evalue', value => $evalue },  
611                              { name => 'start', value => $from},  sub get_cluster_observations{
612                              { name => 'stop' , value => $to}      my ($fid,$datasets_ref,$scope) = (@_);
                             ];  
613    
614        my $dataset = {'class' => 'CLUSTER',
615                       'type' => 'fc',
616                       'context' => $scope,
617                       'fig_id' => $fid
618                       };
619              push (@{$datasets_ref} ,$dataset);              push (@{$datasets_ref} ,$dataset);
620          }          }
621      }  
 }  
622    
623  =head3 get_sims_observations() (internal)  =head3 get_sims_observations() (internal)
624    
# Line 552  Line 630 
630    
631      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
632      my $fig = new FIG;      my $fig = new FIG;
633      my @sims= $fig->nsims($fid,100,1e-20,"fig");      my @sims= $fig->nsims($fid,500,1e-20,"all");
634      my ($dataset);      my ($dataset);
635    
636        my %id_list;
637        foreach my $sim (@sims){
638            my $hit = $sim->[1];
639    
640            next if ($hit !~ /^fig\|/);
641            my @aliases = $fig->feature_aliases($hit);
642            foreach my $alias (@aliases){
643                $id_list{$alias} = 1;
644            }
645        }
646    
647        my %already;
648        my (@new_sims, @uniprot);
649      foreach my $sim (@sims){      foreach my $sim (@sims){
650          my $hit = $sim->[1];          my $hit = $sim->[1];
651            my ($id) = ($hit) =~ /\|(.*)/;
652            next if (defined($already{$id}));
653            next if (defined($id_list{$hit}));
654            push (@new_sims, $sim);
655            $already{$id} = 1;
656        }
657    
658        foreach my $sim (@new_sims){
659            my $hit = $sim->[1];
660            my $percent = $sim->[2];
661          my $evalue = $sim->[10];          my $evalue = $sim->[10];
662          my $from = $sim->[8];          my $qfrom = $sim->[6];
663          my $to = $sim->[9];          my $qto = $sim->[7];
664          $dataset = [ { name => 'class', value => "SIM" },          my $hfrom = $sim->[8];
665                          { name => 'acc' , value => $hit},          my $hto = $sim->[9];
666                          { name => 'type', value => "seq"} ,          my $qlength = $sim->[12];
667                          { name => 'evalue', value => $evalue },          my $hlength = $sim->[13];
668                          { name => 'start', value => $from},          my $db = get_database($hit);
669                          { name => 'stop' , value => $to}          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      push (@{$datasets_ref} ,$dataset);      push (@{$datasets_ref} ,$dataset);
690      }      }
691  }  }
692    
693    =head3 get_database (internal)
694    This method gets the database association from the sequence id
695    
696    =cut
697    
698    sub get_database{
699        my ($id) = (@_);
700    
701        my ($db);
702        if ($id =~ /^fig\|/)              { $db = "FIG" }
703        elsif ($id =~ /^gi\|/)            { $db = "NCBI" }
704        elsif ($id =~ /^^[NXYZA]P_/)      { $db = "RefSeq" }
705        elsif ($id =~ /^sp\|/)            { $db = "SwissProt" }
706        elsif ($id =~ /^uni\|/)           { $db = "UniProt" }
707        elsif ($id =~ /^tigr\|/)          { $db = "TIGR" }
708        elsif ($id =~ /^pir\|/)           { $db = "PIR" }
709        elsif (($id =~ /^kegg\|/) || ($id =~ /Spy/))    { $db = "KEGG" }
710        elsif ($id =~ /^tr\|/)                          { $db = "TrEMBL" }
711        elsif ($id =~ /^eric\|/)          { $db = "ASAP" }
712        elsif ($id =~ /^img\|/)           { $db = "JGI" }
713    
714        return ($db);
715    
716    }
717    
718    
719  =head3 get_identical_proteins() (internal)  =head3 get_identical_proteins() (internal)
720    
721  This methods retrieves sims fills the internal data structures.  This methods retrieves sims fills the internal data structures.
# Line 580  Line 726 
726    
727      my ($fid,$datasets_ref) = (@_);      my ($fid,$datasets_ref) = (@_);
728      my $fig = new FIG;      my $fig = new FIG;
729      my @funcs = ();      my $funcs_ref;
730    
731        my %id_list;
732      my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);      my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid);
733        my @aliases = $fig->feature_aliases($fid);
734        foreach my $alias (@aliases){
735            $id_list{$alias} = 1;
736        }
737    
738      foreach my $id (@maps_to) {      foreach my $id (@maps_to) {
739          my ($tmp, $who);          my ($tmp, $who);
740          if (($id ne $fid) && ($tmp = $fig->function_of($id))) {          if (($id ne $fid) && ($tmp = $fig->function_of($id)) && (! defined ($id_list{$id}))) {
741              if ($id =~ /^fig\|/)           { $who = "FIG" }              $who = &get_database($id);
742              elsif ($id =~ /^gi\|/)            { $who = "NCBI" }              push(@$funcs_ref, [$id,$who,$tmp]);
             elsif ($id =~ /^^[NXYZA]P_/)      { $who = "RefSeq" }  
             elsif ($id =~ /^sp\|/)            { $who = "SwissProt" }  
             elsif ($id =~ /^uni\|/)           { $who = "UniProt" }  
             elsif ($id =~ /^tigr\|/)          { $who = "TIGR" }  
             elsif ($id =~ /^pir\|/)           { $who = "PIR" }  
             elsif ($id =~ /^kegg\|/)          { $who = "KEGG" }  
             elsif ($id =~ /^tr\|/)            { $who = "TrEMBL" }  
             elsif ($id =~ /^eric\|/)          { $who = "ASAP" }  
   
             push(@funcs, [$id,$who,$tmp]);  
743          }          }
744      }      }
745    
746      my ($dataset);      my ($dataset);
747      foreach my $row (@funcs){      my $dataset = {'class' => 'IDENTICAL',
748          my $id = $row->[0];                     'type' => 'seq',
749          my $organism = $fig->org_of($fid);                     'fig_id' => $fid,
750          my $who = $row->[1];                     'rows' => $funcs_ref
751          my $assignment = $row->[2];                     };
752          $dataset = [ { name => 'class', value => "IDENTICAL" },  
                      { name => 'id' , value => $id},  
                      { name => 'organism', value => "$organism"} ,  
                      { name => 'database', value => $who },  
                      { name => 'description' , value => $assignment}  
                      ];  
753          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
754      }  
755    
756  }  }
757    
# Line 646  Line 782 
782                    } @fc_data;                    } @fc_data;
783    
784      my ($dataset);      my ($dataset);
785      foreach my $row (@rows){      my $dataset = {'class' => 'PCH',
786          my $id = $row->[1];                     'type' => 'fc',
787          my $score = $row->[0];                     'fig_id' => $fid,
788          my $description = $row->[2];                     'rows' => \@rows
789          $dataset = [ { name => 'class', value => "FC" },                     };
790                       { name => 'score' , value => $score},  
                      { name => 'id', value => "$id"} ,  
                      { name => 'description' , value => $description}  
                      ];  
791          push (@{$datasets_ref} ,$dataset);          push (@{$datasets_ref} ,$dataset);
792      }  
793  }  }
794    
795  =head3 get_sims_and_bbhs() (internal)  =head3 new (internal)
796    
797  This methods retrieves sims and also BBHs and fills the internal data structures.  Instantiate a new object.
798    
799  =cut  =cut
800    
801  #     sub get_sims_and_bbhs{  sub new {
802      my ($class,$dataset) = @_;
 #       # blast m8 output format  
 #       # id1, id2, %ident, align len, mismatches, gaps, q.start, q.stop, s. start, s.stop, eval, bit  
   
 #       my $Sims=();  
 #       @sims_src = $fig->sims($fid,80,500,"fig",0);  
 #       print "found $#sims_src SIMs\n";  
 #       foreach $sims (@sims_src) {  
 #           my ($sims_string) = "@$sims";  
 # #       print "$sims_string\n";  
 #           my ($rfid,$start,$stop,$eval) = ( $sims_string =~ /\S+\s+(\S+)\s+\S+\s\S+\s+(\S+)\s+(\S+)\s+  
 #                                             \S+\s+\S+\s+\S+\s+\S+\s+(\S+)+.*/);  
 # #       print "ID: $rfid, E:$eval, Start:$start stop:$stop\n";  
 #           $Sims{$rfid}{'eval'}=$eval;  
 #           $Sims{$rfid}{'start'}=$start;  
 #           $Sims{$rfid}{'stop'}=$stop;  
 #           print "$rfid $Sims{$rfid}{'eval'}\n";  
 #       }  
   
 #       # BBHs  
 #       my $BBHs=();  
   
 #       @bbhs_src = $fig->bbhs($fid,1.0e-10);  
 #       print "found $#bbhs_src BBHs\n";  
 #       foreach $bbh (@bbhs_src) {  
 #           #print "@$bbh\n";  
 #           my ($bbh_string) = "@$bbh";  
 #           my ($rfid,$eval,$score) = ( $bbh_string =~ /(\S+)\s(\S+)\s(\S+)/);  
 #           #print "ID: $rfid, E:$eval, S:$score\n";  
 #           $BBHs{$rfid}{'eval'}=$eval;  
 #           $BBHs{$rfid}{'score'}=$score;  
 # #print "$rfid $BBHs{$rfid}{'eval'}\n";  
 #       }  
803    
804  #     }    my $self = { class => $dataset->{'class'},
805                   type => $dataset->{'type'},
806                   fig_id => $dataset->{'fig_id'},
807                   score => $dataset->{'score'},
808               };
809    
810      bless($self,$class);
811    
812      return $self;
813    }
814    
815  =head3 new (internal)  =head3 identity (internal)
816    
817  Instantiate a new object.  Returns the % identity of the similar sequence
818    
819  =cut  =cut
820    
821  sub new {  sub identity {
822    my ($class,$dataset) = @_;      my ($self) = @_;
   
823    
824    #$self = { acc => '',      return $self->{identity};
825  #           description => '',  }
 #           class => '',  
 #           type => '',  
 #           start => '',  
 #           stop => '',  
 #           evalue => '',  
 #           score => '',  
 #           display_method => '',  
 #           feature_id => '',  
 #           rank => '',  
 #           supports_annotation => '',  
 #           id => '',  
 #            organism => '',  
 #            who => ''  
 #         };  
826    
827    my $self = { class => $dataset->{'class'},  =head3 fig_id (internal)
                type => $dataset->{'type'}  
             };  
828    
829    bless($self,$class);  =cut
830    
831    return $self;  sub fig_id {
832      my ($self) = @_;
833      return $self->{fig_id};
834  }  }
835    
836  =head3 feature_id (internal)  =head3 feature_id (internal)
# Line 775  Line 868 
868      return $self->{organism};      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)  =head3 database (internal)
884    
885  Returns the database of the identical sequence  Returns the database of the identical sequence
# Line 787  Line 892 
892      return $self->{database};      return $self->{database};
893  }  }
894    
895  #package Observation::Identical;  sub score {
896  #1;    my ($self) = @_;
 #  
 #our @ISA = qw(Observation);  # inherits all the methods from Observation  
897    
898  =head3 display_identical()    return $self->{score};
899    }
900    
901  If available use the function specified here to display the "raw" observation.  ############################################################
902  This code will display a table for the identical protein  ############################################################
903    package Observation::PDB;
904    
905    use base qw(Observation);
906    
907  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 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  =cut
924    
925  sub display_identical {  sub display{
926      my ($self, $fid, $cgi) = @_;      my ($self,$gd) = @_;
927    
928      my $content;      my $fid = $self->fig_id;
929      my $array=Observation->get_objects($fid);      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 = [];      my $all_domains = [];
1061      my $count_identical = 0;      my $count_identical = 0;
1062      foreach my $thing (@$array) {      my $content;
1063          next if ($thing->class ne "IDENTICAL");      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 = [];          my $single_domain = [];
1069          push(@$single_domain,$thing->class);          push(@$single_domain,$who);
         my $id = $thing->id;  
         $count_identical++;  
1070          push(@$single_domain,&HTML::set_prot_links($cgi,$id));          push(@$single_domain,&HTML::set_prot_links($cgi,$id));
1071          push(@$single_domain,$thing->organism);          push(@$single_domain,$organism);
1072          push(@$single_domain,$thing->database);          push(@$single_domain,$assignment);
         push(@$single_domain,$thing->description);  
1073          push(@$all_domains,$single_domain);          push(@$all_domains,$single_domain);
1074            $count_identical++;
1075      }      }
1076    
1077      if ($count_identical >0){      if ($count_identical >0){
1078          my $table_component = $self->application->component('DomainTable');          $content = $all_domains;
   
         $table_component->columns ([ { 'name' => 'Name', 'filter' => 1 },  
                                      { 'name' => 'ID' },  
                                      { 'name' => 'Organism' },  
                                      { 'name' => 'Database' },  
                                      { 'name' => 'Assignment' }  
                                      ]);  
         $table_component->data($all_domains);  
         $table_component->show_top_browse(1);  
         $table_component->show_bottom_browse(1);  
         $table_component->items_per_page(50);  
         $table_component->show_select_items_per_page(1);  
         $content .= $table_component->output();  
1079      }      }
1080      else{      else{
1081          $content = "<p>This PEG does not have any essentially identical proteins</p>";          $content = "<p>This PEG does not have any essentially identical proteins</p>";
# Line 845  Line 1083 
1083      return ($content);      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;  package Observation::Domain;
1156    
1157  use base qw(Observation);  use base qw(Observation);
# Line 865  Line 1172 
1172  sub display {  sub display {
1173      my ($thing,$gd) = @_;      my ($thing,$gd) = @_;
1174      my $lines = [];      my $lines = [];
1175      my $line_config = { 'title' => $thing->acc,  #    my $line_config = { 'title' => $thing->acc,
1176                          'short_title' => $thing->type,  #                       'short_title' => $thing->type,
1177                          'basepair_offset' => '1' };  #                       'basepair_offset' => '1' };
1178      my $color = "4";      my $color = "4";
1179    
1180      my $line_data = [];      my $line_data = [];
1181      my $links_list = [];      my $links_list = [];
1182      my $descriptions = [];      my $descriptions = [];
1183    
1184      my $description_function;      my $db_and_id = $thing->acc;
1185      $description_function = {"title" => $thing->class,      my ($db,$id) = split("::",$db_and_id);
                              "value" => $thing->acc};  
1186    
1187      push(@$descriptions,$description_function);      my $dbmaster = DBMaster->new(-database =>'Ontology');
1188    
1189        my ($name_title,$name_value,$description_title,$description_value);
1190        if($db eq "CDD"){
1191            my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1192            if(!scalar(@$cdd_objs)){
1193                $name_title = "name";
1194                $name_value = "not available";
1195                $description_title = "description";
1196                $description_value = "not available";
1197            }
1198            else{
1199                my $cdd_obj = $cdd_objs->[0];
1200                $name_title = "name";
1201                $name_value = $cdd_obj->term;
1202                $description_title = "description";
1203                $description_value = $cdd_obj->description;
1204            }
1205        }
1206    
1207        my $line_config = { 'title' => $thing->acc,
1208                            'short_title' => $name_value,
1209                            'basepair_offset' => '1' };
1210    
1211        my $name;
1212        $name = {"title" => $name_title,
1213                 "value" => $name_value};
1214        push(@$descriptions,$name);
1215    
1216        my $description;
1217        $description = {"title" => $description_title,
1218                                 "value" => $description_value};
1219        push(@$descriptions,$description);
1220    
1221      my $score;      my $score;
1222      $score = {"title" => "score",      $score = {"title" => "score",
# Line 886  Line 1224 
1224      push(@$descriptions,$score);      push(@$descriptions,$score);
1225    
1226      my $link_id;      my $link_id;
1227      if ($thing->acc =~/CDD::(\d+)/){      if ($thing->acc =~/\w+::(\d+)/){
1228          $link_id = $1;          $link_id = $1;
1229      }      }
1230    
1231      my $link;      my $link;
1232        my $link_url;
1233        if ($thing->class eq "CDD"){$link_url = "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"}
1234        elsif($thing->class eq "PFAM"){$link_url = "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?$link_id"}
1235        else{$link_url = "NO_URL"}
1236    
1237      $link = {"link_title" => $thing->acc,      $link = {"link_title" => $thing->acc,
1238               "link" => "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"};               "link" => $link_url};
1239      push(@$links_list,$link);      push(@$links_list,$link);
1240    
1241      my $element_hash = {      my $element_hash = {
# Line 911  Line 1254 
1254    
1255  }  }
1256    
1257    sub display_table {
1258        my ($self,$dataset) = @_;
1259        my $cgi = new CGI;
1260        my $data = [];
1261        my $count = 0;
1262        my $content;
1263    
1264        foreach my $thing (@$dataset) {
1265            next if ($thing->type !~ /dom/);
1266            my $single_domain = [];
1267            $count++;
1268    
1269            my $db_and_id = $thing->acc;
1270            my ($db,$id) = split("::",$db_and_id);
1271    
1272            my $dbmaster = DBMaster->new(-database =>'Ontology');
1273    
1274            my ($name_title,$name_value,$description_title,$description_value);
1275            if($db eq "CDD"){
1276                my $cdd_objs = $dbmaster->cdd->get_objects( { 'id' => $id } );
1277                if(!scalar(@$cdd_objs)){
1278                    $name_title = "name";
1279                    $name_value = "not available";
1280                    $description_title = "description";
1281                    $description_value = "not available";
1282                }
1283                else{
1284                    my $cdd_obj = $cdd_objs->[0];
1285                    $name_title = "name";
1286                    $name_value = $cdd_obj->term;
1287                    $description_title = "description";
1288                    $description_value = $cdd_obj->description;
1289                }
1290            }
1291    
1292            my $location =  $thing->start . " - " . $thing->stop;
1293    
1294            push(@$single_domain,$db);
1295            push(@$single_domain,$thing->acc);
1296            push(@$single_domain,$name_value);
1297            push(@$single_domain,$location);
1298            push(@$single_domain,$thing->evalue);
1299            push(@$single_domain,$description_value);
1300            push(@$data,$single_domain);
1301        }
1302    
1303        if ($count >0){
1304            $content = $data;
1305        }
1306        else
1307        {
1308            $content = "<p>This PEG does not have any similarities to domains</p>";
1309        }
1310    }
1311    
1312    
1313    #########################################
1314    #########################################
1315    package Observation::Location;
1316    
1317    use base qw(Observation);
1318    
1319    sub new {
1320    
1321        my ($class,$dataset) = @_;
1322        my $self = $class->SUPER::new($dataset);
1323        $self->{cleavage_prob} = $dataset->{'cleavage_prob'};
1324        $self->{cleavage_loc} = $dataset->{'cleavage_loc'};
1325        $self->{signal_peptide_score} = $dataset->{'signal_peptide_score'};
1326        $self->{cello_location} = $dataset->{'cello_location'};
1327        $self->{cello_score} = $dataset->{'cello_score'};
1328        $self->{tmpred_score} = $dataset->{'tmpred_score'};
1329        $self->{tmpred_locations} = $dataset->{'tmpred_locations'};
1330    
1331        bless($self,$class);
1332        return $self;
1333    }
1334    
1335    sub display {
1336        my ($thing,$gd) = @_;
1337    
1338        my $fid = $thing->fig_id;
1339        my $fig= new FIG;
1340        my $length = length($fig->get_translation($fid));
1341    
1342        my $cleavage_prob;
1343        if($thing->cleavage_prob){$cleavage_prob = $thing->cleavage_prob;}
1344        my ($cleavage_loc_begin,$cleavage_loc_end) = split("-",$thing->cleavage_loc);
1345        my $signal_peptide_score = $thing->signal_peptide_score;
1346        my $cello_location = $thing->cello_location;
1347        my $cello_score = $thing->cello_score;
1348        my $tmpred_score = $thing->tmpred_score;
1349        my @tmpred_locations = split(",",$thing->tmpred_locations);
1350    
1351        my $lines = [];
1352    
1353        #color is
1354        my $color = "6";
1355    
1356        if($cello_location){
1357            my $cello_descriptions = [];
1358            my $line_data =[];
1359    
1360            my $line_config = { 'title' => 'Localization Evidence',
1361                                'short_title' => 'CELLO',
1362                                'basepair_offset' => '1' };
1363    
1364            my $description_cello_location = {"title" => 'Best Cello Location',
1365                                              "value" => $cello_location};
1366    
1367            push(@$cello_descriptions,$description_cello_location);
1368    
1369            my $description_cello_score = {"title" => 'Cello Score',
1370                                           "value" => $cello_score};
1371    
1372            push(@$cello_descriptions,$description_cello_score);
1373    
1374            my $element_hash = {
1375                "title" => "CELLO",
1376                "start" => "1",
1377                "end" =>  $length + 1,
1378                "color"=> $color,
1379                "type" => 'box',
1380                "zlayer" => '1',
1381                "description" => $cello_descriptions};
1382    
1383            push(@$line_data,$element_hash);
1384            $gd->add_line($line_data, $line_config);
1385        }
1386    
1387    
1388        $color = "2";
1389        if($tmpred_score){
1390            my $line_data =[];
1391            my $line_config = { 'title' => 'Localization Evidence',
1392                                'short_title' => 'Transmembrane',
1393                                'basepair_offset' => '1' };
1394    
1395    
1396            foreach my $tmpred (@tmpred_locations){
1397                my $descriptions = [];
1398                my ($begin,$end) =split("-",$tmpred);
1399                my $description_tmpred_score = {"title" => 'TMPRED score',
1400                                 "value" => $tmpred_score};
1401    
1402                push(@$descriptions,$description_tmpred_score);
1403    
1404                my $element_hash = {
1405                "title" => "transmembrane location",
1406                "start" => $begin + 1,
1407                "end" =>  $end + 1,
1408                "color"=> $color,
1409                "zlayer" => '5',
1410                "type" => 'smallbox',
1411                "description" => $descriptions};
1412    
1413                push(@$line_data,$element_hash);
1414    
1415            }
1416            $gd->add_line($line_data, $line_config);
1417        }
1418    
1419        $color = "1";
1420        if($signal_peptide_score){
1421            my $line_data = [];
1422            my $descriptions = [];
1423    
1424            my $line_config = { 'title' => 'Localization Evidence',
1425                                'short_title' => 'SignalP',
1426                                'basepair_offset' => '1' };
1427    
1428            my $description_signal_peptide_score = {"title" => 'signal peptide score',
1429                                                    "value" => $signal_peptide_score};
1430    
1431            push(@$descriptions,$description_signal_peptide_score);
1432    
1433            my $description_cleavage_prob = {"title" => 'cleavage site probability',
1434                                             "value" => $cleavage_prob};
1435    
1436            push(@$descriptions,$description_cleavage_prob);
1437    
1438            my $element_hash = {
1439                "title" => "SignalP",
1440                "start" => $cleavage_loc_begin - 2,
1441                "end" =>  $cleavage_loc_end + 1,
1442                "type" => 'bigbox',
1443                "color"=> $color,
1444                "zlayer" => '10',
1445                "description" => $descriptions};
1446    
1447            push(@$line_data,$element_hash);
1448            $gd->add_line($line_data, $line_config);
1449        }
1450    
1451        return ($gd);
1452    
1453    }
1454    
1455    sub cleavage_loc {
1456      my ($self) = @_;
1457    
1458      return $self->{cleavage_loc};
1459    }
1460    
1461    sub cleavage_prob {
1462      my ($self) = @_;
1463    
1464      return $self->{cleavage_prob};
1465    }
1466    
1467    sub signal_peptide_score {
1468      my ($self) = @_;
1469    
1470      return $self->{signal_peptide_score};
1471    }
1472    
1473    sub tmpred_score {
1474      my ($self) = @_;
1475    
1476      return $self->{tmpred_score};
1477    }
1478    
1479    sub tmpred_locations {
1480      my ($self) = @_;
1481    
1482      return $self->{tmpred_locations};
1483    }
1484    
1485    sub cello_location {
1486      my ($self) = @_;
1487    
1488      return $self->{cello_location};
1489    }
1490    
1491    sub cello_score {
1492      my ($self) = @_;
1493    
1494      return $self->{cello_score};
1495    }
1496    
1497    
1498    #########################################
1499    #########################################
1500    package Observation::Sims;
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.8  
changed lines
  Added in v.1.29

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3