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

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.40

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3