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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3