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

Diff of /FigKernelPackages/FIGO.pm

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

revision 1.7, Thu Feb 22 14:05:27 2007 UTC revision 1.30, Fri Nov 30 21:35:51 2007 UTC
# Line 1  Line 1 
1    ########################################################################
2  #  #
3  # Copyright (c) 2003-2006 University of Chicago and Fellowship  # Copyright (c) 2003-2006 University of Chicago and Fellowship
4  # for Interpretations of Genomes. All Rights Reserved.  # for Interpretations of Genomes. All Rights Reserved.
# Line 14  Line 15 
15  # Genomes at veronika@thefig.info or download a copy from  # Genomes at veronika@thefig.info or download a copy from
16  # http://www.theseed.org/LICENSE.TXT.  # http://www.theseed.org/LICENSE.TXT.
17  #  #
18    ########################################################################
19    
20  package FIGO;  =head1 TODO
21    
22    =over 4
23    
24    =item Null arg to ContigO::dna_seq() should return entire contig seq.
25    
26    =item Add method to access "FIG::crude_estimate_of_distance()"
27    
28    =back
29    
30    =cut
31    
32    =head1 Overview
33    
34    This module is a set of packages encapsulating the SEED's core methods
35    using an "OOP-like" style.
36    
37    There are several modules clearly related to "individual genomes:"
38    GenomeO, ContigO, FeatureO (and I<maybe> AnnotationO).
39    
40    There are also modules that deal with complex relationships between
41    pairs or sets of features in one, two, or more genomes,
42    rather than any particular single genome:
43    BBHO, CouplingO, SubsystemO, FunctionalRoleO, FigFamO.
44    
45    Finally, the methods in "Attribute" might in principle attach
46    "atributes" to any type of object.
47    (Likewise, in principle one might also want to attach an "annotation"
48    to any type of object,
49    although currently we only support annotations of "features.")
50    
51    The three modules that act on "individual genomes" have a reasonable clear
52    "implied heirarchy" relative to FIGO:
53    
54    =over 4
55    
56        FIGO > GenomeO > ContigO > FeatureO
57    
58    =back
59    
60    However, inheritance is B<NOT> implemented using the C<@ISA> mechanism,
61    because some methods deal with "pairwise" or "setwise" relations between objects
62    or other more complex relationships that do not naturally fit into any heirarchy ---
63    which would get us into the whole quagmire of "multiple inheritance."
64    
65    We have chosen to in many cases sidestep the entire issue of inheritance
66    via an I<ad hoc> mechanism:
67    If a "child" object needs access to its "ancestors'" methods,
68    we will explicitly pass it references to its "ancestors,"
69    as subroutine arguments.
70    This is admittedly ugly, clumsy, and potentially error-prone ---
71    but it has the advantage that, unlike multiple inheritance,
72    we understand how to do it...
73    
74    MODULE DEPENDENCIES: FIG, FIG_Config, FigFams, SFXlate, SproutFIG, Tracer,
75        gjoparseblast, Data::Dumper.
76    
77    =cut
78    
79    ########################################################################
80    package FIGO;
81    ########################################################################
82  use strict;  use strict;
83  use FIG;  use FIG;
84  use FIG_Config;  use FIG_Config;
# Line 24  Line 86 
86  use SproutFIG;  use SproutFIG;
87  use Tracer;  use Tracer;
88  use Data::Dumper;  use Data::Dumper;
89    use Carp;
90  use FigFams;  use FigFams;
91  use gjoparseblast;  use gjoparseblast;
92    
93  =head1 FIGO Methods  =head1 FIGO
94    
95    The effective "base class" containing a few "top-level" methods.
96    
97    =cut
98    
99    
100  =head3 new  =head3 new
101    
# Line 64  Line 132 
132      return bless $self, $class;      return bless $self, $class;
133  }  }
134    
135    sub function_of {
136        my($self,$id) = @_;
137    
138        my $fig  = $self->{_fig};
139        my $func = $fig->function_of($id);
140    
141        return ($func ? $func : "");
142    }
143    
144  =head3 genomes  =head3 genomes
145    
# Line 80  Line 155 
155  C<< my @tax_ids = $figo->genomes( @constraints ); >>  C<< my @tax_ids = $figo->genomes( @constraints ); >>
156    
157  =item @constraints  =item @constraints
158    
159  One or more element of: complete, prokaryotic, eukaryotic, bacterial, archaeal, nmpdr.  One or more element of: complete, prokaryotic, eukaryotic, bacterial, archaeal, nmpdr.
160    
161  =item RETURNS: List of Tax-IDs.  =item RETURNS: List of Tax-IDs.
162    
163  =item EXAMPLE: L<Display all complete, prokaryotic genomes>  =item EXAMPLE:
164    
165    L<Display all complete, prokaryotic genomes>
166    
167  =back  =back
168    
# Line 141  Line 219 
219  =over4  =over4
220    
221  =item RETURNS:  =item RETURNS:
222    
223  List of all subsystems.  List of all subsystems.
224    
225  =item EXAMPLE: L<Accessing Subsystem data>  =item EXAMPLE:
226    
227    L<Accessing Subsystem data>
228    
229  =back  =back
230    
# Line 188  Line 269 
269    
270  =over4  =over4
271    
272  =item USAGE:  C<< foreach $fam ($figO->all_figfams) { #...Do something } >>  =item USAGE:
273    
274    C<< foreach $fam ($figO->all_figfams) { #...Do something } >>
275    
276  =item RETURNS: List of FIGfam Objects  =item RETURNS:
277    
278  =item EXAMPLE: L<Accessing FIGfams>  List of FIGfam Objects
279    
280    =item EXAMPLE:
281    
282    L<Accessing FIGfams>
283    
284  =back  =back
285    
# Line 211  Line 298 
298    
299  =over4  =over4
300    
301  =item USAGE:   C<< my ($fam, $sims) = $figO->family_containing($seq); >>  =item USAGE:
302    
303  =item $seq:    A protein translation string.  C<< my ($fam, $sims) = $figO->family_containing($seq); >>
304    
305    =item $seq:
306    
307    A protein translation string.
308    
309  =item RETURNS:  =item RETURNS:
310    
311        $fam:  A FIGfam Object.        $fam:  A FIGfam Object.
312    
313        $sims: A set of similarity objects.        $sims: A set of similarity objects.
314    
315  =item EXAMPLE: L<Placing a sequence into a FIGfam>  =item EXAMPLE: L<Placing a sequence into a FIGfam>
# Line 241  Line 334 
334      }      }
335  }  }
336    
337    =head3 figfam
338    
339    =over 4
340    
341    =item USAGE:
342    
343    C<< my $fam = $figO->figfam($family_id); >>
344    
345    =item $family_id;
346    
347    A FigFam ID
348    
349    =item RETURNS:
350    
351    $fam:  A FIGfam Object.
352    
353    =back
354    
355    =cut
356    
357    sub figfam {
358        my($self,$fam_id) = @_;
359    
360        return &FigFamO::new('FigFamO',$self,$fam_id);
361    }
362    
363    
364  ########################################################################  ########################################################################
365  package GenomeO;  package GenomeO;
# Line 251  Line 370 
370    
371  =cut  =cut
372    
373    
374  =head3 new  =head3 new
375    
376  Constructor of GenomeO objects.  Constructor of GenomeO objects.
# Line 258  Line 378 
378  =over4  =over4
379    
380  =item USAGE:  =item USAGE:
 C<< my $org = GenomeO->new($figo, $tax_id); >>  
381    
382  =item RETURNS: A new GenomeO object.  C<< my $orgO = GenomeO->new($figO, $tax_id); >>
383    
384    =item RETURNS:
385    
386    A new "GenomeO" object.
387    
388  =back  =back
389    
# Line 281  Line 404 
404    
405  =over4  =over4
406    
407  =item USAGE:   C<< my $tax_id = $org->id(); >>  =item USAGE:
408    
409    C<< my $tax_id = $orgO->id(); >>
410    
411    =item RETURNS:
412    
413  =item RETURNS: Taxonomy-ID of GenomeO object.  Taxonomy-ID of "GenomeO" object.
414    
415  =back  =back
416    
# Line 301  Line 428 
428    
429  =over4  =over4
430    
431  =item USAGE:   C<< $gs = $genome->genus_species(); >>  =item USAGE:
432    
433    C<< $gs = $orgO->genus_species(); >>
434    
435  =item RETURNS: Genus-species-strain string  =item RETURNS:
436    
437    Genus-species-strain string
438    
439  =back  =back
440    
# Line 317  Line 448 
448  }  }
449    
450    
451    
452    
453    =head3 taxonomy_of
454    
455    =over 4
456    
457    =item FUNCTION:
458    
459    Return the TAXONOMY string of a "GenomeO" object.
460    
461    =item USAGE:
462    
463    C<< my $taxonomy = $orgO->taxonomy_of(); >>
464    
465    =item RETURNS:
466    
467    TAXONOMY string.
468    
469    =back
470    
471    =cut
472    
473    sub taxonomy_of {
474        my ($self) = @_;
475    
476        my $figO = $self->{_figO};
477        my $fig  = $figO->{_fig};
478    
479        return $fig->taxonomy_of($self->{_id});
480    }
481    
482    
483  =head3 contigs_of  =head3 contigs_of
484    
485  =over4  =over4
486    
487  =item RETURNS: List of C<contig> objects contained in a C<GenomeO> object.  =item RETURNS:
488    
489    List of C<contig> objects contained in a C<GenomeO> object.
490    
491    =item EXAMPLE:
492    
493  =item EXAMPLE: L<Show how to access contigs and extract sequence>  L<Show how to access contigs and extract sequence>
494    
495  =back  =back
496    
# Line 341  Line 508 
508    
509  =head3 features_of  =head3 features_of
510    
511    =over 4
512    
513    =item FUNCTION:
514    
515    Returns a list of "FeatureO" objects contained in a "GenomeO" object.
516    
517    =item USAGE:
518    
519    C<< my @featureOs = $orgO->features_of();        #...Fetch all features >>
520    
521    or
522    
523    C<< my @featureOs = $orgO->features_of('peg');   #...Fetch only PEGs >>
524    
525    =item RETURNS:
526    
527    List of "FeatureO" objects.
528    
529    =back
530    
531  =cut  =cut
532    
533  sub features_of {  sub features_of {
# Line 359  Line 546 
546    
547  =over4  =over4
548    
549  =item USAGE:   C<< $genome->display(); >>  =item USAGE:
550    
551    C<< $genome->display(); >>
552    
553  =item RETURNS: Null  =item RETURNS:
554    
555    (Void)
556    
557  =back  =back
558    
# Line 393  Line 584 
584  =over4  =over4
585    
586  =item USAGE:  =item USAGE:
587    
588  C<< $contig = ContigO->new( $figO, $genomeId, $contigId); >>  C<< $contig = ContigO->new( $figO, $genomeId, $contigId); >>
589    
590  =item $figO: A FIGO object.  =item $figO:
591    
592    Parent FIGO object.
593    
594    =item $genomeId:
595    
596    Taxon-ID for the genome the contig is from.
597    
598    =item $contigId:
599    
600  =item $genomeId: Taxon-ID for the genome the contig is from.  Identifier for the contig
601    
602  =item $contigId: Identifier for the contig  =item RETURNS:
603    
604  =item RETURNS: A "ContigO" object.  A "ContigO" object.
605    
606  =back  =back
607    
# Line 423  Line 623 
623    
624  =over4  =over4
625    
626  =item RETURNS: Sequence ID string of "ContigO" object  =item RETURNS:
627    
628    Sequence ID string of "ContigO" object
629    
630  =back  =back
631    
# Line 441  Line 643 
643  =over4  =over4
644    
645  =item USAGE:  =item USAGE:
     C<< my $tax_id = $contig->genome(); >>  
646    
647  =item RETURNS: GenomeO object containing the contig object.  C<< my $tax_id = $contig->genome->id(); >>
648    
649    =item RETURNS:
650    
651    Tax-ID of the GenomeO object containing the contig object.
652    
653  =back  =back
654    
# Line 452  Line 657 
657  sub genome {  sub genome {
658      my($self) = @_;      my($self) = @_;
659    
660      return $self->{_genome};      my $figO = $self->{_figO};
661        return new GenomeO($figO,$self->{_genome});
662  }  }
663    
664    
# Line 462  Line 668 
668  =over4  =over4
669    
670  =item USAGE:  =item USAGE:
671    
672      C<< my $len = $contig->contig_length(); >>      C<< my $len = $contig->contig_length(); >>
673    
674  =item RETURNS: Length of contig's DNA sequence.  =item RETURNS:
675    
676    Length of contig's DNA sequence.
677    
678  =back  =back
679    
# Line 474  Line 683 
683      my($self) = @_;      my($self) = @_;
684    
685      my $fig = $self->{_figO}->{_fig};      my $fig = $self->{_figO}->{_fig};
686      my $contig_lengths = $fig->contig_lengths($self->genome);      my $contig_lengths = $fig->contig_lengths($self->genome->id);
687      return $contig_lengths->{$self->id};      return $contig_lengths->{$self->id};
688  }  }
689    
# Line 484  Line 693 
693  =over4  =over4
694    
695  =item USAGE:  =item USAGE:
696    
697      C<< my $seq = $contig->dna_seq(beg, $end); >>      C<< my $seq = $contig->dna_seq(beg, $end); >>
698    
699  =item $beg: Begining point of DNA subsequence  =item $beg:
700    
701  =item $end: End point of DNA subsequence  Begining point of DNA subsequence
702    
703  =item RETURNS: string of DNA sequence from $beg to $end  =item $end:
704    
705    End point of DNA subsequence
706    
707    =item RETURNS:
708    
709    String containing DNA subsequence running from $beg to $end
710  (NOTE: if $beg > $end, returns reverse complement of DNA subsequence.)  (NOTE: if $beg > $end, returns reverse complement of DNA subsequence.)
711    
712  =back  =back
# Line 506  Line 721 
721      if (($beg && (&FIG::between(1,$beg,$max))) &&      if (($beg && (&FIG::between(1,$beg,$max))) &&
722          ($end && (&FIG::between(1,$end,$max))))          ($end && (&FIG::between(1,$end,$max))))
723      {      {
724          return $fig->dna_seq($self->genome,join("_",($self->id,$beg,$end)));          return $fig->dna_seq($self->genome->id,join("_",($self->id,$beg,$end)));
725      }      }
726      else      else
727      {      {
# Line 527  Line 742 
742    
743  =over4  =over4
744    
745  =item RETURNS: Nil  =item RETURNS:
746    
747    (Void)
748    
749  =back  =back
750    
# Line 536  Line 753 
753  sub display {  sub display {
754      my($self) = @_;      my($self) = @_;
755    
756      print join("ContigO",$self->genome,$self->id,$self->contig_length),"\n";      print join("ContigO",$self->genome->id,$self->id,$self->contig_length),"\n";
757    }
758    
759    sub features_in_region {
760        my($self,$beg,$end) = @_;
761        my $figO = $self->{_figO};
762        my $fig = $figO->{_fig};
763    
764        my($features) = $fig->genes_in_region($self->genome->id,$self->id,$beg,$end);
765        return map { new FeatureO($figO,$_) } @$features;
766  }  }
767    
768    
# Line 545  Line 771 
771  package FeatureO;  package FeatureO;
772  ########################################################################  ########################################################################
773  use Data::Dumper;  use Data::Dumper;
774    use Carp;
775    
776  =head1 FeatureO  =head1 FeatureO
777    
778    Methods for working with features on "ContigO" objects.
779    
780  =cut  =cut
781    
782    
783    =head3 new
784    
785    Constructor of new "FeatureO" objects
786    
787    =over 4
788    
789    =item USAGE:
790    
791    C<< my $feature = FeatureO->new( $figO, $fid ); >>
792    
793    =item C<$figO>:
794    
795    "Base" FIGO object.
796    
797    =item C<$fid>:
798    
799    Feature-ID for new feature
800    
801  =head1 new  =item RETURNS:
802    
803    A newly created "FeatureO" object.
804    
805  Constructor of "FeatureO" objects  =back
806    
807  =cut  =cut
808    
# Line 569  Line 817 
817  }  }
818    
819    
820    
821  =head3 id  =head3 id
822    
823    =over 4
824    
825    =item USAGE:
826    
827    C<< my $fid = $feature->id(); >>
828    
829    =item RETURNS:
830    
831    The FID (Feature ID) of a "FeatureO" object.
832    
833    =back
834    
835  =cut  =cut
836    
837  sub id {  sub id {
# Line 583  Line 844 
844    
845  =head3 genome  =head3 genome
846    
847    =over 4
848    
849    =item USAGE:
850    
851    C<< my $taxid = $feature->genome(); >>
852    
853    =item RETURNS:
854    
855    The Taxon-ID for the "GenomeO" object containing the feature.
856    
857    =back
858    
859  =cut  =cut
860    
861  sub genome {  sub genome {
862      my($self) = @_;      my($self) = @_;
863        my $figO = $self->{_figO};
864      $self->id =~ /^fig\|(\d+\.\d+)/;      $self->id =~ /^fig\|(\d+\.\d+)/;
865      return $1;      return new GenomeO($figO,$1);
866  }  }
867    
868    
869    
870  =head3 type  =head3 type
871    
872    =over 4
873    
874    =item USAGE:
875    
876    C<< my $feature_type = $feature->type(); >>
877    
878    =item RETURNS:
879    
880    The feature object's "type" (e.g., "peg," "rna," etc.)
881    
882    =back
883    
884  =cut  =cut
885    
886  sub type {  sub type {
# Line 607  Line 892 
892    
893    
894    
   
895  =head3 location  =head3 location
896    
897    =over 4
898    
899    =item USAGE:
900    
901    C<< my $loc = $feature->location(); >>
902    
903    =item RETURNS:
904    
905    A string representing the feature object's location on the genome's DNA,
906    in SEED "tbl format" (i.e., "contig_beging_end").
907    
908    =back
909    
910  =cut  =cut
911    
912  sub location {  sub location {
# Line 620  Line 917 
917  }  }
918    
919    
920    =head3 contig
921    
922    =over 4
923    
924    =item USAGE:
925    
926    C<< my $contig = $feature->contig(); >>
927    
928    =item RETURNS:
929    
930    A "ContigO" object to access the contig data
931    for the contig the feature is on.
932    
933    =back
934    
935    =cut
936    
937    sub contig {
938        my($self) = @_;
939    
940        my $figO = $self->{_figO};
941        my $loc      = $self->location;
942        my $genomeID = $self->genome->id;
943        return ($loc =~ /^(\S+)_\d+_\d+$/) ? new ContigO($figO,$genomeID,$1) : undef;
944    }
945    
946    
947    
948    =head3 begin
949    
950    =over 4
951    
952    =item USAGE:
953    
954    C<< my $beg = $feature->begin(); >>
955    
956    =item RETURNS:
957    
958    The numerical coordinate of the first base of the feature.
959    
960    =back
961    
962    =cut
963    
964    sub begin {
965        my($self) = @_;
966    
967        my $loc = $self->location;
968        return ($loc =~ /^\S+_(\d+)_\d+$/) ? $1 : undef;
969    }
970    
971    
972    
973    =head3 end
974    
975    =over 4
976    
977    =item USAGE:
978    
979    C<< my $end = $feature->end(); >>
980    
981    =item RETURNS:
982    
983    The numerical coordinate of the last base of the feature.
984    
985    =back
986    
987    =cut
988    
989    sub end {
990        my($self) = @_;
991    
992        my $loc = $self->location;
993        return ($loc =~ /^\S+_\d+_(\d+)$/) ? $1 : undef;
994    }
995    
996    
997    
998  =head3 dna_seq  =head3 dna_seq
999    
1000    =over 4
1001    
1002    =item USAGE:
1003    
1004    C<< my $dna_seq = $feature->dna_seq(); >>
1005    
1006    =item RETURNS:
1007    
1008    A string contining the DNA subsequence of the contig
1009    running from the first to the last base of the feature.
1010    
1011    If ($beg > $end), the reverse complement subsequence is returned.
1012    
1013    =back
1014    
1015  =cut  =cut
1016    
1017  sub dna_seq {  sub dna_seq {
# Line 638  Line 1027 
1027    
1028  =head3 prot_seq  =head3 prot_seq
1029    
1030    =over 4
1031    
1032    =item USAGE:
1033    
1034    C<< my $dna_seq = $feature->prot_seq(); >>
1035    
1036    =item RETURNS:
1037    
1038    A string contining the protein translation of the feature (if it exists),
1039    or the "undef" value if the feature does not exist or is not a PEG.
1040    
1041    =back
1042    
1043  =cut  =cut
1044    
1045  sub prot_seq {  sub prot_seq {
# Line 653  Line 1055 
1055    
1056  =head3 function_of  =head3 function_of
1057    
1058    =over 4
1059    
1060    =item USAGE:
1061    
1062    C<< my $func = $feature->function_of(); >>
1063    
1064    =item RETURNS:
1065    
1066    A string containing the function assigned to the feature,
1067    or the "undef" value if no function has been assigned.
1068    
1069    =back
1070    
1071  =cut  =cut
1072    
1073  sub function_of {  sub function_of {
# Line 667  Line 1082 
1082    
1083  =head3 coupled_to  =head3 coupled_to
1084    
1085    =over 4
1086    
1087    =item USAGE:
1088    
1089    C<< my @coupled_features = $feature->coupled_to(); >>
1090    
1091    =item RETURNS:
1092    
1093    A list of "CouplingO" objects describing the evidence for functional coupling
1094    between this feature and other nearby features.
1095    
1096    =back
1097    
1098  =cut  =cut
1099    
1100  sub coupled_to {  sub coupled_to {
1101      my($self) = @_;      my($self) = @_;
1102    
1103      ($self->type eq "peg") || return undef;      ($self->type eq "peg") || return ();
1104      my $figO = $self->{_figO};      my $figO = $self->{_figO};
1105      my $fig  = $figO->{_fig};      my $fig  = $figO->{_fig};
1106      my $peg1 = $self->id;      my $peg1 = $self->id;
# Line 689  Line 1117 
1117    
1118  =head3 annotations  =head3 annotations
1119    
1120    =over 4
1121    
1122    =item USAGE:
1123    
1124    C<< my @annot_list = $feature->annotations(); >>
1125    
1126    =item RETURNS:
1127    
1128    A list of "AnnotationO" objects allowing access to the annotations for this feature.
1129    
1130    =back
1131    
1132  =cut  =cut
1133    
1134  sub annotations {  sub annotations {
# Line 700  Line 1140 
1140      return map { &AnnotationO::new('AnnotationO',@$_) } $fig->feature_annotations($self->id,1);      return map { &AnnotationO::new('AnnotationO',@$_) } $fig->feature_annotations($self->id,1);
1141  }  }
1142    
1143    
1144    =head3 in_subsystems
1145    
1146    =over 4
1147    
1148    =item USAGE:
1149    
1150    C<< my @subsys_list = $feature->in_subsystems(); >>
1151    
1152    =item RETURNS:
1153    
1154    A list of "SubsystemO" objects allowing access to the subsystems
1155    that this feature particupates in.
1156    
1157    =back
1158    
1159    =cut
1160    
1161  sub in_subsystems {  sub in_subsystems {
1162      my($self) = @_;      my($self) = @_;
1163      my $figO = $self->{_figO};      my $figO = $self->{_figO};
# Line 711  Line 1169 
1169    
1170  =head3 possibly_truncated  =head3 possibly_truncated
1171    
1172    =over 4
1173    
1174    =item USAGE:
1175    
1176    C<< my $trunc = $feature->possibly_truncated(); >>
1177    
1178    =item RETURNS:
1179    
1180    Boolean C<TRUE> if the feature may be truncated;
1181    boolean C<FALSE> otherwise.
1182    
1183    =back
1184    
1185  =cut  =cut
1186    
1187  sub possibly_truncated {  sub possibly_truncated {
# Line 725  Line 1196 
1196    
1197  =head3 possible_frameshift  =head3 possible_frameshift
1198    
1199    =over 4
1200    
1201    =item USAGE:
1202    
1203    C<< my $fs = $feature->possible_frameshift(); >>
1204    
1205    =item RETURNS:
1206    
1207    Boolean C<TRUE> if the feature may be a frameshifted fragment;
1208    boolean C<FALSE> otherwise.
1209    
1210    (NOTE: This is a crude prototype implementation,
1211    and is mostly as an example of how to code using FIGO.)
1212    
1213    =back
1214    
1215  =cut  =cut
1216    
1217  sub possible_frameshift {  sub possible_frameshift {
1218      my($self) = @_;      my($self) = @_;
1219      my $figO = $self->{_figO};      my $figO = $self->{_figO};
1220        my $fig = $figO->{_fig};
1221      my($tmp_dir) = $figO->{_tmp_dir};      my($tmp_dir) = $figO->{_tmp_dir};
1222    
1223        my $tmp_dna  = "$tmp_dir/tmp_dna.$$.fasta";
1224        my $tmp_prot = "$tmp_dir/tmp_prot.$$.fasta";
1225    
1226        #...Skip tests and return '0' if truncated...
1227      if (! $self->possibly_truncated)      if (! $self->possibly_truncated)
1228      {      {
1229          my @sims = $self->sims( -max => 1, -cutoff => 1.0e-50);          #...Get best precomputed BLAST hit if E-value < 1.0e-20:
1230            my @sims = $self->sims( -max => 5, -cutoff => 1.0e-20);
1231            while ((@sims > 0) && $fig->possibly_truncated($sims[0]->id2)) { shift @sims }
1232    
1233            #...If a sim was returned:
1234          if (my $sim = shift @sims)          if (my $sim = shift @sims)
1235          {          {
1236                #...Get best hit FID and boundaries:
1237              my $peg2 = $sim->id2;              my $peg2 = $sim->id2;
1238              my $ln1  = $sim->ln1;              my $ln1  = $sim->ln1;
1239              my $ln2  = $sim->ln2;              my $ln2  = $sim->ln2;
1240              my $b2   = $sim->b2;              my $b2   = $sim->b2;
1241              my $e2   = $sim->e2;              my $e2   = $sim->e2;
1242    
1243                #...Convert from AA to BP, and pad out w/ 100 bp guard region:
1244              my $adjL = 100 + (($b2-1) * 3);              my $adjL = 100 + (($b2-1) * 3);
1245              my $adjR = 100 + (($ln2 - $e2) * 3);              my $adjR = 100 + (($ln2 - $e2) * 3);
1246    
1247                if ($ENV{DEBUG}) { print STDERR "adjL = $adjL adjR = $adjR ln1 = $ln1 peg2 = $peg2 ln2 = $ln2\n" }
1248                #...If hit is more than 20% longer than query:
1249              if ($ln2 > (1.2 * $ln1))              if ($ln2 > (1.2 * $ln1))
1250              {              {
1251                    #...Get and parse query location:
1252                  my $loc = $self->location;                  my $loc = $self->location;
1253                  if ($loc =~ /^(\S+)_(\d+)_(\d+)/)                  if ($loc =~ /^(\S+)_(\d+)_(\d+)/)
1254                  {                  {
1255                      my $contig = $1;                      my $contig = $1;
1256                      my $beg    = $2;                      my $beg    = $2;
1257                      my $end = $3;                      my $end = $3;
1258                      my $contigO = new ContigO($figO,$self->genome,$contig);  
1259                      my $begA = &max(1,$beg - $adjL);                      #...Create new ContigO object:
1260                      my $endA = &min($end+$adjR,$contigO->contig_length);                      my $contigO = new ContigO($figO, $self->genome->id, $contig);
1261                      my $dna  = $contigO->dna_seq($begA,$endA);  
1262                      open(TMP,">$tmp_dir/tmp_dna") || die "couild not open tmp_dna";                      #...Extract DNA subsequence, including guard regions:
1263                        my($begA,$endA,$dna);
1264                        if ($beg < $end)
1265                        {
1266                            $begA = &max(1, $beg - $adjL);
1267                            $endA = &min($end+$adjR, $contigO->contig_length);
1268                            $dna  = $contigO->dna_seq($begA,$endA);
1269                        }
1270                        else
1271                        {
1272                            $endA = &max(1, $beg - $adjL);
1273                            $begA = &min($end+$adjR, $contigO->contig_length);
1274                            $dna  = $contigO->dna_seq($begA,$endA);
1275                        }
1276    
1277                        if (defined($dna) && (length($dna) > 90))
1278                        {
1279                            #...Open tmp-file and write FASTA containing DNA subregion to be BLASTed:
1280                            open( TMP, ">$tmp_dna") || die "could not open $tmp_dna";
1281                      print TMP ">dna\n$dna\n";                      print TMP ">dna\n$dna\n";
1282                      close(TMP);                      close(TMP);
1283    
1284                      my $peg2O = new FeatureO($figO,$peg2);                          #...Create new FeatureO object corresponding tp $peg2:
1285                      my $prot  = $peg2O->prot_seq;                          my $pegO2 = new FeatureO($figO,$peg2);
1286                      open(TMP,">$tmp_dir/tmp_prot") || die "could not open tmp_prot";  
1287                            #...Fetch its translation, and print to tmp FASTA file for BLASTing:
1288                            my $prot  = $pegO2->prot_seq;
1289                            if (defined($prot) && (length($prot) > 30))
1290                            {
1291                                open( TMP, ">$tmp_prot") || die "could not open $tmp_prot";
1292                      print TMP ">tmp_prot\n$prot\n";                      print TMP ">tmp_prot\n$prot\n";
1293                      close(TMP);                      close(TMP);
1294                      &run("formatdb -i $tmp_dir/tmp_dna -pF");  
1295                      open(BLAST,"blastall -i $tmp_dir/tmp_prot -d $tmp_dir/tmp_dna -p tblastn -FF -e 1.0e-50 |")                              #...Build BLAST nucleotide database for extracted DNA region,
1296                                #   and TBLASTN $peg2 against the DNA:
1297                                &run("formatdb -i $tmp_dna -pF");
1298                                open(BLAST,"blastall -i $tmp_prot -d $tmp_dna -p tblastn -FF -e 1.0e-20 |")
1299                          || die "could not blast";                          || die "could not blast";
1300    
1301                                #...Parse the TBLASTN output; find and sort HSPs by left boundary:
1302                      my $db_seq_out = &gjoparseblast::next_blast_subject(\*BLAST,1);                      my $db_seq_out = &gjoparseblast::next_blast_subject(\*BLAST,1);
1303                                if ($ENV{DEBUG}) { print STDERR &Dumper(['blast output',$db_seq_out]) }
1304                      my @hsps       = sort { $a->[0] <=> $b->[0] }                      my @hsps       = sort { $a->[0] <=> $b->[0] }
1305                                       map { [$_->[9],$_->[10],$_->[12],$_->[13]] }                                       map { [$_->[9],$_->[10],$_->[12],$_->[13]] }
1306                                       grep { $_->[1] < 1.0e-50 }                                                grep { $_->[1] < 1.0e-20 }
1307                                       @{$db_seq_out->[6]};                                       @{$db_seq_out->[6]};
1308    
1309                                #...Extract HSP boundary pairs:
1310                      my @prot = map { [$_->[0],$_->[1]] } @hsps;                      my @prot = map { [$_->[0],$_->[1]] } @hsps;
1311                      my @dna  = map { [$_->[2],$_->[3]] } @hsps;                      my @dna  = map { [$_->[2],$_->[3]] } @hsps;
1312                      if (&covers(\@prot,length($prot),3) && &covers(\@dna,3*length($prot),9))                              if ($ENV{DEBUG}) { print STDERR &Dumper(\@prot,\@dna) }
1313    
1314                                #...If the "cover" of the HSPs covers more than 90% of $peg2 w gaps < 3 AA,
1315                                #   and the "cover" of the HPSs cover more than 90% of the extracted DNA
1316                                #   w/ gaps < 9 bp (but not a multiple of 3), suspect a possible frameshift:
1317                                if (&covers(\@prot,length($prot),3,0) && &covers(\@dna,3*length($prot),9,1))
1318                      {                      {
1319                          return 1;                                  unlink($tmp_dna,$tmp_prot);
1320                                    return [$contig,$begA,$endA,$dna,$peg2];
1321                                }
1322                      }                      }
1323                  }                  }
1324              }              }
1325          }          }
1326      }      }
1327        }
1328        unlink($tmp_dna,$tmp_prot);
1329      return 0;      return 0;
1330  }  }
1331    
# Line 791  Line 1333 
1333    
1334  =head3 run  =head3 run
1335    
1336    (Note: This function should be considered "PRIVATE")
1337    
1338    =over 4
1339    
1340    =item FUNCTION:
1341    
1342    Passes a string containing a command to be execture by the "system" shell command.
1343    
1344    =item USAGE:
1345    
1346    C<< $feature->run($cmd); >>
1347    
1348    =item RETURNS:
1349    
1350    Nil if the execution of C<$cmd> was successful;
1351    aborts with traceback if C<$cmd> fails.
1352    
1353    =back
1354    
1355  =cut  =cut
1356    
1357  sub run {  sub run {
1358      my($cmd) = @_;      my($cmd) = @_;
1359      (system($cmd) == 0) || Confess("FAILED: $cmd");      (system($cmd) == 0) || confess("FAILED: $cmd");
1360  }  }
1361    
1362    
1363    
1364  =head3 max  =head3 max
1365    
1366    (Note: This function should be considered "PRIVATE")
1367    
1368    =over 4
1369    
1370    =item USAGE:
1371    
1372    C<< my $max = $feature->max($x, $y); >>
1373    
1374    =item C<$x> and  C<$y>
1375    
1376    Numerical values.
1377    
1378    =item RETURNS:
1379    
1380    The larger of the two numerical values C<$x> and C<$y>.
1381    
1382    =back
1383    
1384  =cut  =cut
1385    
1386  sub max {  sub max {
# Line 813  Line 1392 
1392    
1393  =head3 min  =head3 min
1394    
1395    (Note: This function should be considered "PRIVATE")
1396    
1397    =over 4
1398    
1399    =item USAGE:
1400    
1401    C<< my $min = $feature->min($x, $y); >>
1402    
1403    =item C<$x> and C<$y>
1404    
1405    Numerical values.
1406    
1407    =item RETURNS:
1408    
1409    The smaller of the two numerical values C<$x> and C<$y>.
1410    
1411    =back
1412    
1413  =cut  =cut
1414    
1415  sub min {  sub min {
# Line 824  Line 1421 
1421    
1422  =head3 covers  =head3 covers
1423    
1424    (Question: Should this function be considered "PRIVATE" ???)
1425    
1426    USAGE:
1427        C<< if (&covers(\@hits, $len, $diff, $must_shift)) { #...Do stuff } >>
1428    
1429    Returns boolean C<TRUE> if a set of BLAST HSPs "cover" more than 90%
1430    of the database sequence(?).
1431    
1432  =cut  =cut
1433    
1434  sub covers {  sub covers {
1435      my($hsps,$ln,$diff) = @_;      my($hsps,$ln,$diff,$must_shift) = @_;
1436    
1437        if ($ENV{DEBUG}) { print STDERR &Dumper(['hsps',$hsps,'ln',$ln,'diff',$diff,'must_shift',$must_shift]) }
1438      my $hsp1 = shift @$hsps;      my $hsp1 = shift @$hsps;
1439      my $hsp2;      my $hsp2;
1440      while ($hsp1 && ($hsp2 = shift @$hsps) && ($hsp1 = &merge($hsp1,$hsp2,$diff))) {}      my $merged = 0;
1441      return ($hsp1 && (($hsp1->[1] - $hsp1->[0]) > (0.9 * $ln)));      while ($hsp1 && ($hsp2 = shift @$hsps) &&
1442               ($must_shift ? &diff_frames($hsp1,$hsp2) : 1) &&
1443               ($hsp1 = &merge($hsp1,$hsp2,$diff)))
1444        {
1445            $merged = 1;
1446            if ($ENV{DEBUG}) { print STDERR &Dumper(['merged',$hsp1]) }
1447        }
1448        return ($merged && $hsp1 && (($hsp1->[1] - $hsp1->[0]) > (0.9 * $ln)));
1449    }
1450    
1451    sub diff_frames {
1452        my($hsp1,$hsp2) = @_;
1453        return ((($hsp1->[1]+1) % 3) != ($hsp2->[0] % 3));
1454  }  }
1455    
1456    
1457    
1458  =head3 merge  =head3 merge
1459    
1460    Merge two HSPs unless their overlap or separation is too large.
1461    
1462    RETURNS: Merged boundaries if merger succeeds, and C<undef> if merger fails.
1463    
1464  =cut  =cut
1465    
# Line 846  Line 1468 
1468    
1469      my($b1,$e1) = @$hsp1;      my($b1,$e1) = @$hsp1;
1470      my($b2,$e2) = @$hsp2;      my($b2,$e2) = @$hsp2;
1471      return (($e2 > $e1) && (abs($b2-$e1) <= $diff)) ? [$b1,$e2] : undef;      return (($e2 > $e1) && (($b2-$e1) <= $diff)) ? [$b1,$e2] : undef;
1472  }  }
1473    
1474    
1475    
1476  =head3 sims  =head3 sims
1477    
1478    =over 4
1479    
1480    =item FUNCTION:
1481    
1482    Returns precomputed "Sim.pm" objects from the SEED.
1483    
1484    =item USAGE:
1485    
1486    C<< my @sims = $pegO->sims( -all, -cutoff => 1.0e-10); >>
1487    
1488    C<< my @sims = $pegO->sims( -max => 50, -cutoff => 1.0e-10); >>
1489    
1490    =item RETURNS: List of sim objects.
1491    
1492    =back
1493    
1494  =cut  =cut
1495    
1496  use Sim;  use Sim;
# Line 863  Line 1501 
1501      my $fig  = $figO->{_fig};      my $fig  = $figO->{_fig};
1502    
1503      my $cutoff = $args{-cutoff} ? $args{-cutoff} : 1.0e-5;      my $cutoff = $args{-cutoff} ? $args{-cutoff} : 1.0e-5;
1504      my $all    = $args{-all}    ? $args{-all}    : "fig";      my $all    = $args{-all}    ? 'all'          : "fig";
1505      my $max    = $args{-max}    ? $args{-max}    : 10000;      my $max    = $args{-max}    ? $args{-max}    : 10000;
1506    
1507      return $fig->sims($self->id,$max,$cutoff,$all);      my @sims = $fig->sims($self->id,$max,$cutoff,$all);
1508    
1509        if (@sims) {
1510            my $peg1 = FeatureO->new($figO, $sims[0]->[0]);
1511    
1512            foreach my $sim (@sims) {
1513    #           $sim->[0] = $peg1;
1514    #           $sim->[1] = FeatureO->new($figO, $sim->[1]);
1515            }
1516        }
1517    
1518        return @sims;
1519  }  }
1520    
1521    
1522    
1523  =head3 bbhs  =head3 bbhs
1524    
1525    =over 4
1526    
1527    =item FUNCTION:
1528    
1529    Given a PEG-type "FeatureO" object, returns the list of BBHO objects
1530    corresponding to the pre-computed BBHs for that PEG.
1531    
1532    =item USAGE:
1533    
1534    C<< my @bbhs = $pegO->bbhs(); >>
1535    
1536    =item RETURNS:
1537    
1538    List of BBHO objects.
1539    
1540    =back
1541    
1542  =cut  =cut
1543    
1544  sub bbhs {  sub bbhs {
# Line 890  Line 1556 
1556                                                  },'BBHO') } @bbhs;                                                  },'BBHO') } @bbhs;
1557  }  }
1558    
1559    
1560  =head3 display  =head3 display
1561    
1562    =over 4
1563    
1564    =item FUNCTION:
1565    
1566    Prints info about a "FeatureO" object to STDOUT.
1567    
1568    =item USAGE:
1569    
1570    C<< $pegO->display(); >>
1571    
1572    =item RETURNS;
1573    
1574    (void)
1575    
1576    =back
1577    
1578  =cut  =cut
1579    
1580  sub display {  sub display {
# Line 910  Line 1593 
1593    
1594  =head1 BBHO  =head1 BBHO
1595    
1596    Methods for accessing "Bidirectiona Best Hits" (BBHs).
1597    
1598  =cut  =cut
1599    
1600    
1601  =head3 new  =head3 new
1602    
1603    Constructor of BBHO objects.
1604    
1605    (NOTE: The "average user" should never need to invoke this method.)
1606    
1607  =cut  =cut
1608    
1609  sub new {  sub new {
# Line 930  Line 1619 
1619  }  }
1620    
1621    
1622    
1623  =head3 peg1  =head3 peg1
1624    
1625    =over 4
1626    
1627    =item USAGE:
1628    
1629    C<< my $peg1 = $bbh->peg1(); >>
1630    
1631    =item RETURNS:
1632    
1633    A "FeatureO" object corresponding to the "query" sequence
1634    in a BBH pair.
1635    
1636    =back
1637    
1638  =cut  =cut
1639    
1640  sub peg1 {  sub peg1 {
# Line 943  Line 1646 
1646    
1647  =head3 peg2  =head3 peg2
1648    
1649    =over 4
1650    
1651    =item USAGE:
1652    
1653    C<< my $peg2 = $bbh->peg2(); >>
1654    
1655    =item RETURNS:
1656    
1657    A "FeatureO" object corresponding to the "database" sequence
1658    in a BBH pair.
1659    
1660    =back
1661    
1662  =cut  =cut
1663    
1664  sub peg2 {  sub peg2 {
# Line 956  Line 1672 
1672    
1673  =head3 psc  =head3 psc
1674    
1675    =over 4
1676    
1677    =item USAGE:
1678    
1679    C<< my $psc = $bbh->psc(); >>
1680    
1681    =item RETURNS:
1682    
1683    The numerical value of the BLAST E-value for the pair.
1684    
1685    =back
1686    
1687  =cut  =cut
1688    
1689  sub psc {  sub psc {
# Line 968  Line 1696 
1696    
1697  =head3 norm_bitscore  =head3 norm_bitscore
1698    
1699    
1700    =over 4
1701    
1702    =item USAGE:
1703    
1704    C<< my $bsc = $bbh->norm_bitscore(); >>
1705    
1706    =item RETURNS:
1707    
1708    The "BLAST bit-score per aligned character" for the pair.
1709    
1710    =back
1711    
1712  =cut  =cut
1713    
1714  sub norm_bitscore {  sub norm_bitscore {
# Line 984  Line 1725 
1725    
1726  =head1 AnnotationO  =head1 AnnotationO
1727    
1728    Methods for accessing SEED annotations.
1729    
1730  =cut  =cut
1731    
1732    
1733    
1734  =head3 new  =head3 new
1735    
1736    =over 4
1737    
1738    =item FUNCTION:
1739    
1740    Cronstruct a new "AnnotationO" object
1741    
1742    =item USAGE:
1743    
1744    C<< my $annotO = AnnotationO->new( $fid, $timestamp, $who, $text); >>
1745    
1746    =item C<$fid>
1747    
1748    A feature identifier.
1749    
1750    =item C<$timestamp>
1751    
1752    The C<UN*X> timestamp one wishes to associate with the annotation.
1753    
1754    =item C<$who>
1755    
1756    The annotator's user-name.
1757    
1758    =item C<$text>
1759    
1760    The textual content of the annotation.
1761    
1762    =item RETURNS:
1763    
1764    An "AnnotationO" object.
1765    
1766    =back
1767    
1768  =cut  =cut
1769    
1770  sub new {  sub new {
# Line 1007  Line 1782 
1782    
1783  =head3 fid  =head3 fid
1784    
1785    =over 4
1786    
1787    =item FUNCTION:
1788    
1789    Extract the feature-ID that was annotated.
1790    
1791    =item USAGE:
1792    
1793    C<< my $fid = $annotO->fid(); >>
1794    
1795    =item RETURNS;
1796    
1797    The feature-ID as a string.
1798    
1799    =back
1800    
1801  =cut  =cut
1802    
1803  sub fid {  sub fid {
# Line 1019  Line 1810 
1810    
1811  =head3 timestamp  =head3 timestamp
1812    
1813    =over 4
1814    
1815    =item FUNCTION:
1816    
1817    Extract the C<UN*X> timestamp of the annotation.
1818    
1819    =item USAGE:
1820    
1821    C<< my $fid = $annotO->timestamp(); >>
1822    
1823    =item RETURNS;
1824    
1825    The timestamp as a string.
1826    
1827    =back
1828    
1829  =cut  =cut
1830    
1831  sub timestamp {  sub timestamp {
# Line 1038  Line 1845 
1845    
1846  =head3 made_by  =head3 made_by
1847    
1848    =over 4
1849    
1850    =item FUNCTION:
1851    
1852    Extract the annotator's user-name.
1853    
1854    =item USAGE:
1855    
1856    C<< my $fid = $annotO->made_by(); >>
1857    
1858    =item RETURNS;
1859    
1860    The username of the annotator, as a string.
1861    
1862    =back
1863    
1864  =cut  =cut
1865    
1866  sub made_by {  sub made_by {
# Line 1052  Line 1875 
1875    
1876  =head3 text  =head3 text
1877    
1878    =over 4
1879    
1880    =item FUNCTION:
1881    
1882    Extract the text of the annotation.
1883    
1884    =item USGAE:
1885    
1886    C<< my $text = $annotO->text(); >>
1887    
1888    =item RETURNS:
1889    
1890    The text of the annotation, as a string.
1891    
1892    =back
1893    
1894  =cut  =cut
1895    
1896  sub text {  sub text {
# Line 1064  Line 1903 
1903    
1904  =head3 display  =head3 display
1905    
1906    =over 4
1907    
1908    =item FUNCTION:
1909    
1910    Print the contents of an "AnnotationO" object to B<STDOUT>
1911    in human-readable form.
1912    
1913    =item USAGE:
1914    
1915    C<< my $annotO->display(); >>
1916    
1917    =item RETURNS:
1918    
1919    (void)
1920    
1921    =back
1922    
1923  =cut  =cut
1924    
1925  sub display {  sub display {
# Line 1079  Line 1935 
1935  ########################################################################  ########################################################################
1936  use Data::Dumper;  use Data::Dumper;
1937    
1938    =head1 CouplingO
1939    
1940    Methods for accessing the "Functional coupling scores"
1941    of PEGs in close physical proximity to each other.
1942    
1943    =cut
1944    
1945    
1946    
1947  =head3 new  =head3 new
1948    
1949    =over 4
1950    
1951    =item FUNCTION:
1952    
1953    Construct a new "CouplingO" object
1954    encapsulating the "functional coupling" score
1955    between a pair of features in some genome.
1956    
1957    =item USAGE:
1958    
1959    C<< $couplingO = CouplingO->new($figO, $fid1, $fid2, $sc); >>
1960    
1961    =item C<$figO>
1962    
1963    Parent "FIGO" object.
1964    
1965    =item C<$fid1> and C<$fid2>
1966    
1967    A pair of feature-IDs.
1968    
1969    =item C<$sc>
1970    
1971    A functional-coupling score
1972    
1973    =item RETURNS:
1974    
1975    A "CouplingO" object.
1976    
1977    =back
1978    
1979  =cut  =cut
1980    
1981  sub new {  sub new {
# Line 1100  Line 1995 
1995    
1996  =head3 peg1  =head3 peg1
1997    
1998    =over 4
1999    
2000    =item FUNCTION:
2001    
2002    Returns a "FeatureO" object corresponding to the first FID in a coupled pair.
2003    
2004    =item USAGE:
2005    
2006    C<< my $peg1 = $couplingO->peg1(); >>
2007    
2008    =item RETURNS:
2009    
2010    A "FeatureO" object.
2011    
2012    =back
2013    
2014  =cut  =cut
2015    
2016  sub peg1 {  sub peg1 {
# Line 1111  Line 2022 
2022    
2023    
2024    
2025  =head3 peg1  =head3 peg2
2026    
2027    =over 4
2028    
2029    =item FUNCTION:
2030    
2031    Returns a "FeatureO" object corresponding to the second FID in a coupled pair.
2032    
2033    =item USAGE:
2034    
2035    C<< my $peg2 = $couplingO->peg2(); >>
2036    
2037    =item RETURNS:
2038    
2039    A "FeatureO" object.
2040    
2041    =back
2042    
2043  =cut  =cut
2044    
# Line 1126  Line 2053 
2053    
2054  =head3 sc  =head3 sc
2055    
2056    =over 4
2057    
2058    =item FUNCTION:
2059    
2060    Extracts the "functional coupling" score from a "CouplingO" object.
2061    
2062    =item USAGE:
2063    
2064    C<< my $sc = $couplingO->sc(); >>
2065    
2066    =item RETURNS:
2067    
2068    A scalar score.
2069    
2070    =back
2071    
2072  =cut  =cut
2073    
2074  sub sc {  sub sc {
# Line 1138  Line 2081 
2081    
2082  =head3 evidence  =head3 evidence
2083    
2084    =over 4
2085    
2086    =item FUNCTION:
2087    
2088    Fetch the evidence for a "functional coupling" between two close PEGs,
2089    in the form of a list of objects describing the "Pairs of Close Homologs" (PCHs)
2090    supporting the existence of a functional coupling between the two close PEGs.
2091    
2092    =item USAGE:
2093    
2094    C<< my $evidence = $couplingO->evidence(); >>
2095    
2096    =item RETURNS
2097    
2098    List of pairs of "FeatureO" objects.
2099    
2100    =back
2101    
2102  =cut  =cut
2103    
2104  sub evidence {  sub evidence {
# Line 1146  Line 2107 
2107      my $figO = $self->{_figO};      my $figO = $self->{_figO};
2108      my $fig  = $figO->{_fig};      my $fig  = $figO->{_fig};
2109      my @ev = ();      my @ev = ();
2110      foreach my $tuple ($fig->coupling_evidence($self->peg1,$self->peg2))      foreach my $tuple ($fig->coupling_evidence($self->peg1->id,$self->peg2->id))
2111      {      {
2112          my($peg3,$peg4,$rep) = @$tuple;          my($peg3,$peg4,$rep) = @$tuple;
2113          push(@ev,[&FeatureO::new('FeatureO',$figO,$peg3),          push(@ev,[&FeatureO::new('FeatureO',$figO,$peg3),
# Line 1160  Line 2121 
2121    
2122  =head3 display  =head3 display
2123    
2124    =over 4
2125    
2126    =item FUNCTION:
2127    
2128    Print the contents of a "CouplingO" object to B<STDOUT> in human-readable form.
2129    
2130    =item USAGE:
2131    
2132    C<< $couplingO->display(); >>
2133    
2134    =item RETURNS:
2135    
2136    (Void)
2137    
2138    =back
2139    
2140  =cut  =cut
2141    
2142  sub display {  sub display {
# Line 1212  Line 2189 
2189    
2190  =head3 usable  =head3 usable
2191    
2192    
2193  =cut  =cut
2194    
2195  sub usable {  sub usable {
# Line 1234  Line 2212 
2212      my $figO = $self->{_figO};      my $figO = $self->{_figO};
2213      my $subO = $self->{_subO};      my $subO = $self->{_subO};
2214      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }
     if (! defined($subO) { return undef }  
2215    
2216      return map { &GenomeO::new('GenomeO',$figO,$_) } $subO->get_genomes;      return map { &GenomeO::new('GenomeO',$figO,$_) } $subO->get_genomes;
2217  }  }
# Line 1251  Line 2228 
2228      my $figO = $self->{_figO};      my $figO = $self->{_figO};
2229      my $subO = $self->{_subO};      my $subO = $self->{_subO};
2230      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }
2231      if (! defined($subO) { return undef }  
2232      return map { &FunctionalRoleO::new('FunctionalRoleO',$figO,$_) }  $subO->get_roles($self->id);      return map { &FunctionalRoleO::new('FunctionalRoleO',$figO,$_) }  $subO->get_roles($self->id);
2233  }  }
2234    
2235    
2236    
2237  =head3 curator  =head3 curator
2238    
2239  =cut  =cut
# Line 1266  Line 2245 
2245      my $subO = $self->{_subO};      my $subO = $self->{_subO};
2246      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }
2247    
2248      return defined($subO) ? $subO->get_curator : undef;      return $subO->get_curator;
2249  }  }
2250    
2251    
# Line 1282  Line 2261 
2261      my $figO = $self->{_figO};      my $figO = $self->{_figO};
2262      my $subO = $self->{_subO};      my $subO = $self->{_subO};
2263      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }
     if (! defined($subO) { return undef }  
2264    
2265      return $subO->get_variant_code_for_genome($genome->id);      return $subO->get_variant_code_for_genome($genome->id);
2266  }  }
# Line 1299  Line 2277 
2277      my $figO = $self->{_figO};      my $figO = $self->{_figO};
2278      my $subO = $self->{_subO};      my $subO = $self->{_subO};
2279      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }      if (! $subO) { $subO = $self->{_subO} = new Subsystem($self->{_id},$figO->{_fig}); }
     if (! defined($subO) { return undef }  
2280    
2281      return $subO->get_pegs_from_cell($genome->id,$role->id);      return $subO->get_pegs_from_cell($genome->id,$role->id);
2282  }  }
# Line 1313  Line 2290 
2290    
2291  =head1 FunctionalRoleO  =head1 FunctionalRoleO
2292    
2293    Methods for accessing the functional roles of features.
2294    
2295  =cut  =cut
2296    
2297    
# Line 1409  Line 2388 
2388      my $famO = $self->{_famO};      my $famO = $self->{_famO};
2389      if (! $famO) { $famO = $self->{_famO} = &FigFam::new('FigFam',$fig,$self->id) }      if (! $famO) { $famO = $self->{_famO} = &FigFam::new('FigFam',$fig,$self->id) }
2390    
2391      return map { &FigFamO::new('FigFamO',$figO,$_) } $famO->list_members;      return map { &FeatureO::new('FeatureO',$figO,$_) } $famO->list_members;
2392  }  }
2393    
   
   
2394  =head3 rep_seqs  =head3 rep_seqs
2395    
2396  =cut  =cut
# Line 1465  Line 2442 
2442  ########################################################################  ########################################################################
2443  =head1 Attribute  =head1 Attribute
2444    
2445    (Note yet implemented.)
2446    
2447  =cut  =cut
2448    
2449  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3