[Bio] / Sprout / Sprout.pm Repository:
ViewVC logotype

Diff of /Sprout/Sprout.pm

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

revision 1.1, Sun Jan 23 16:12:29 2005 UTC revision 1.16, Fri Jun 24 21:45:45 2005 UTC
# Line 11  Line 11 
11          use Tracer;          use Tracer;
12          use FIGRules;          use FIGRules;
13          use Stats;          use Stats;
14        use POSIX qw(strftime);
15    
16    
17  =head1 Sprout Database Manipulation Object  =head1 Sprout Database Manipulation Object
# Line 33  Line 34 
34    
35  =cut  =cut
36    
37  #  #: Constructor SFXlate->new_sprout_only();
38    
39  =head2 Public Methods  =head2 Public Methods
40    
# Line 121  Line 122 
122  and 10999.  and 10999.
123    
124  =cut  =cut
125    #: Return Type $;
126  sub MaxSegment {  sub MaxSegment {
127          my $self = shift @_;      my ($self) = @_;
128          return $self->{_options}->{maxSegmentLength};          return $self->{_options}->{maxSegmentLength};
129  }  }
130    
# Line 136  Line 137 
137  we generally only need a few sequences in memory rather than the entire contig.  we generally only need a few sequences in memory rather than the entire contig.
138    
139  =cut  =cut
140    #: Return Type $;
141  sub MaxSequence {  sub MaxSequence {
142          my $self = shift @_;      my ($self) = @_;
143          return $self->{_options}->{maxSequenceLength};          return $self->{_options}->{maxSequenceLength};
144  }  }
145    
# Line 231  Line 232 
232    
233  sub Get {  sub Get {
234          # Get the parameters.          # Get the parameters.
235          my $self = shift @_;      my ($self, $objectNames, $filterClause, $parameterList) = @_;
         my ($objectNames, $filterClause, $parameterList) = @_;  
236          # We differ from the ERDB Get method in that the parameter list is passed in as a list reference          # We differ from the ERDB Get method in that the parameter list is passed in as a list reference
237          # rather than a list of parameters. The next step is to convert the parameters from a reference          # rather than a list of parameters. The next step is to convert the parameters from a reference
238          # to a real list. We can only do this if the parameters have been specified.          # to a real list. We can only do this if the parameters have been specified.
# Line 268  Line 268 
268    
269  sub GetEntity {  sub GetEntity {
270          # Get the parameters.          # Get the parameters.
271          my $self = shift @_;      my ($self, $entityType, $ID) = @_;
272          my ($entityType, $ID) = @_;      # Call the ERDB method.
273          # Create a query.      return $self->{_erdb}->GetEntity($entityType, $ID);
         my $query = $self->Get([$entityType], "$entityType(id) = ?", [$ID]);  
         # Get the first (and only) object.  
         my $retVal = $query->Fetch();  
         # Return the result.  
         return $retVal;  
274  }  }
275    
276  =head3 GetEntityValues  =head3 GetEntityValues
# Line 305  Line 300 
300  =back  =back
301    
302  =cut  =cut
303    #: Return Type @;
304  sub GetEntityValues {  sub GetEntityValues {
305          # Get the parameters.          # Get the parameters.
306          my $self = shift @_;      my ($self, $entityType, $ID, $fields) = @_;
307          my ($entityType, $ID, $fields) = @_;      # Call the ERDB method.
308          # Get the specified entity.      return $self->{_erdb}->GetEntityValues($entityType, $ID, $fields);
         my $entity = $self->GetEntity($entityType, $ID);  
         # Declare the return list.  
         my @retVal = ();  
         # If we found the entity, push the values into the return list.  
         if ($entity) {  
                 push @retVal, $entity->Values($fields);  
         }  
         # Return the result.  
         return @retVal;  
309  }  }
310    
311  =head3 ShowMetaData  =head3 ShowMetaData
# Line 340  Line 326 
326    
327  sub ShowMetaData {  sub ShowMetaData {
328          # Get the parameters.          # Get the parameters.
329          my $self = shift @_;      my ($self, $fileName) = @_;
         my ($fileName) = @_;  
330          # Compute the file name.          # Compute the file name.
331          my $options = $self->{_options};          my $options = $self->{_options};
332          # Call the show method on the underlying ERDB object.          # Call the show method on the underlying ERDB object.
# Line 378  Line 363 
363  =back  =back
364    
365  =cut  =cut
366    #: Return Type %;
367  sub Load {  sub Load {
368          # Get the parameters.          # Get the parameters.
369          my $self = shift @_;      my ($self, $rebuild) = @_;
         my ($rebuild) = @_;  
370          # Get the database object.          # Get the database object.
371          my $erdb = $self->{_erdb};          my $erdb = $self->{_erdb};
372          # Load the tables from the data directory.          # Load the tables from the data directory.
# Line 422  Line 406 
406  =back  =back
407    
408  =cut  =cut
409    #: Return Type $%;
410  sub LoadUpdate {  sub LoadUpdate {
411          # Get the parameters.          # Get the parameters.
412          my $self = shift @_;      my ($self, $truncateFlag, $tableList) = @_;
         my ($truncateFlag, $tableList) = @_;  
413          # Get the database object.          # Get the database object.
414          my $erdb = $self->{_erdb};          my $erdb = $self->{_erdb};
415          # Declare the return value.          # Declare the return value.
# Line 459  Line 442 
442  changed.  changed.
443    
444  =cut  =cut
445    #: Return Type ;
446  sub Build {  sub Build {
447          # Get the parameters.          # Get the parameters.
448          my $self = shift @_;      my ($self) = @_;
449          # Create the tables.          # Create the tables.
450          $self->{_erdb}->CreateTables;          $self->{_erdb}->CreateTables;
451  }  }
# Line 474  Line 457 
457  Return a list of all the genome IDs.  Return a list of all the genome IDs.
458    
459  =cut  =cut
460    #: Return Type @;
461  sub Genomes {  sub Genomes {
462          # Get the parameters.          # Get the parameters.
463          my $self = shift @_;      my ($self) = @_;
464          # Get all the genomes.          # Get all the genomes.
465          my @retVal = $self->GetFlat(['Genome'], "", [], 'Genome(id)');          my @retVal = $self->GetFlat(['Genome'], "", [], 'Genome(id)');
466          # Return the list of IDs.          # Return the list of IDs.
# Line 504  Line 487 
487  =back  =back
488    
489  =cut  =cut
490    #: Return Type $;
491  sub GenusSpecies {  sub GenusSpecies {
492          # Get the parameters.          # Get the parameters.
493          my $self = shift @_;      my ($self, $genomeID) = @_;
         my ($genomeID) = @_;  
494          # Get the data for the specified genome.          # Get the data for the specified genome.
495          my @values = $self->GetEntityValues('Genome', $genomeID, ['Genome(genus)', 'Genome(species)',          my @values = $self->GetEntityValues('Genome', $genomeID, ['Genome(genus)', 'Genome(species)',
496                                                                                                                            'Genome(unique-characterization)']);                                                                                                                            'Genome(unique-characterization)']);
# Line 541  Line 523 
523  =back  =back
524    
525  =cut  =cut
526    #: Return Type @;
527  sub FeaturesOf {  sub FeaturesOf {
528          # Get the parameters.          # Get the parameters.
529          my $self = shift @_;      my ($self, $genomeID,$ftype) = @_;
         my ($genomeID,$ftype) = @_;  
530          # Get the features we want.          # Get the features we want.
531          my @features;          my @features;
532          if (!$ftype) {          if (!$ftype) {
# Line 594  Line 575 
575  =back  =back
576    
577  =cut  =cut
578    #: Return Type @;
579    #: Return Type $;
580  sub FeatureLocation {  sub FeatureLocation {
581          # Get the parameters.          # Get the parameters.
582          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
583          # Create a query for the feature locations.          # Create a query for the feature locations.
584          my $query = $self->Get(['IsLocatedIn'], "IsLocatedIn(from-link) = ? ORDER BY IsLocatedIn(locN)",          my $query = $self->Get(['IsLocatedIn'], "IsLocatedIn(from-link) = ? ORDER BY IsLocatedIn(locN)",
585                                                     [$featureID]);                                                     [$featureID]);
# Line 656  Line 637 
637  =back  =back
638    
639  =cut  =cut
640    #: Return Type @;
641  sub ParseLocation {  sub ParseLocation {
642          # Get the parameter.      # Get the parameter. Note that if we're called as an instance method, we ignore
643        # the first parameter.
644        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
645          my ($location) = @_;          my ($location) = @_;
646          # Parse it into segments.          # Parse it into segments.
647          $location =~ /^(.*)_(\d*)([+-_])(\d*)$/;          $location =~ /^(.*)_(\d*)([+-_])(\d*)$/;
# Line 677  Line 660 
660          return ($contigID, $start, $dir, $len);          return ($contigID, $start, $dir, $len);
661  }  }
662    
663    =head3 PointLocation
664    
665    C<< my $found = Sprout::PointLocation($location, $point); >>
666    
667    Return the offset into the specified location of the specified point on the contig. If
668    the specified point is before the location, a negative value will be returned. If it is
669    beyond the location, an undefined value will be returned. It is assumed that the offset
670    is for the location's contig. The location can either be new-style (using a C<+> or C<->
671    and a length) or old-style (using C<_> and start and end positions.
672    
673    =over 4
674    
675    =item location
676    
677    A location specifier (see L</FeatureLocation> for a description).
678    
679    =item point
680    
681    The offset into the contig of the point in which we're interested.
682    
683    =item RETURN
684    
685    Returns the offset inside the specified location of the specified point, a negative
686    number if the point is before the location, or an undefined value if the point is past
687    the location. If the length of the location is 0, this method will B<always> denote
688    that it is outside the location. The offset will always be relative to the left-most
689    position in the location.
690    
691    =back
692    
693    =cut
694    #: Return Type $;
695    sub PointLocation {
696        # Get the parameter. Note that if we're called as an instance method, we ignore
697        # the first parameter.
698        shift if UNIVERSAL::isa($_[0],__PACKAGE__);
699        my ($location, $point) = @_;
700        # Parse out the location elements. Note that this works on both old-style and new-style
701        # locations.
702        my ($contigID, $start, $dir, $len) = ParseLocation($location);
703        # Declare the return variable.
704        my $retVal;
705        # Compute the offset. The computation is dependent on the direction of the location.
706        my $offset = (($dir == '+') ? $point - $start : $point - ($start - $len + 1));
707        # Return the offset if it's valid.
708        if ($offset < $len) {
709            $retVal = $offset;
710        }
711        # Return the offset found.
712        return $retVal;
713    }
714    
715  =head3 DNASeq  =head3 DNASeq
716    
717  C<< my $sequence = $sprout->DNASeq(\@locationList); >>  C<< my $sequence = $sprout->DNASeq(\@locationList); >>
718    
719  This method returns the DNA sequence represented by a list of locations. The list of locations  This method returns the DNA sequence represented by a list of locations. The list of locations
720  should be of the form returned by L</feature_location> when in a list context. In other words,  should be of the form returned by L</featureLocation> when in a list context. In other words,
721  each location is of the form I<contigID>C<_>I<begin>I<dir>I<end>.  each location is of the form I<contigID>C<_>I<begin>I<dir>I<end>.
722    
723  =over 4  =over 4
# Line 699  Line 734 
734  =back  =back
735    
736  =cut  =cut
737    #: Return Type $;
738  sub DNASeq {  sub DNASeq {
739          # Get the parameters.          # Get the parameters.
740          my $self = shift @_;      my ($self, $locationList) = @_;
         my ($locationList) = @_;  
741          # Create the return string.          # Create the return string.
742          my $retVal = "";          my $retVal = "";
743          # Loop through the locations.          # Loop through the locations.
# Line 773  Line 807 
807  =back  =back
808    
809  =cut  =cut
810    #: Return Type @;
811  sub AllContigs {  sub AllContigs {
812          # Get the parameters.          # Get the parameters.
813          my $self = shift @_;      my ($self, $genomeID) = @_;
         my ($genomeID) = @_;  
814          # Ask for the genome's Contigs.          # Ask for the genome's Contigs.
815          my @retVal = $self->GetFlat(['HasContig'], "HasContig(from-link) = ?", [$genomeID],          my @retVal = $self->GetFlat(['HasContig'], "HasContig(from-link) = ?", [$genomeID],
816                                                                  'HasContig(to-link)');                                                                  'HasContig(to-link)');
# Line 797  Line 830 
830    
831  ID of the contig whose length is desired.  ID of the contig whose length is desired.
832    
833    =item RETURN
834    
835    Returns the number of positions in the contig.
836    
837  =back  =back
838    
839  =cut  =cut
840    #: Return Type $;
841  sub ContigLength {  sub ContigLength {
842          # Get the parameters.          # Get the parameters.
843          my $self = shift @_;      my ($self, $contigID) = @_;
         my ($contigID) = @_;  
844          # Get the contig's last sequence.          # Get the contig's last sequence.
845          my $query = $self->Get(['IsMadeUpOf'],          my $query = $self->Get(['IsMadeUpOf'],
846                  "IsMadeUpOf(from-link) = ? ORDER BY IsMadeUpOf(start-position) DESC",                  "IsMadeUpOf(from-link) = ? ORDER BY IsMadeUpOf(start-position) DESC",
# Line 846  Line 882 
882  Returns a three-element list. The first element is a list of feature IDs for the features that  Returns a three-element list. The first element is a list of feature IDs for the features that
883  overlap the region of interest. The second and third elements are the minimum and maximum  overlap the region of interest. The second and third elements are the minimum and maximum
884  locations of the features provided on the specified contig. These may extend outside  locations of the features provided on the specified contig. These may extend outside
885  the start and stop values.  the start and stop values. The first element (that is, the list of features) is sorted
886    roughly by location.
887    
888  =back  =back
889    
890  =cut  =cut
891    #: Return Type @@;
892  sub GenesInRegion {  sub GenesInRegion {
893          # Get the parameters.          # Get the parameters.
894          my $self = shift @_;      my ($self, $contigID, $start, $stop) = @_;
         my ($contigID, $start, $stop) = @_;  
895          # Get the maximum segment length.          # Get the maximum segment length.
896          my $maximumSegmentLength = $self->MaxSegment;          my $maximumSegmentLength = $self->MaxSegment;
897          # Create a hash to receive the feature list. We use a hash so that we can eliminate          # Create a hash to receive the feature list. We use a hash so that we can eliminate
898          # duplicates easily.      # duplicates easily. The hash key will be the feature ID. The value will be a two-element
899        # containing the minimum and maximum offsets. We will use the offsets to sort the results
900        # when we're building the result set.
901          my %featuresFound = ();          my %featuresFound = ();
902          # Prime the values we'll use for the returned beginning and end.          # Prime the values we'll use for the returned beginning and end.
903          my ($min, $max) = ($self->ContigLength($contigID), 0);      my @initialMinMax = ($self->ContigLength($contigID), 0);
904        my ($min, $max) = @initialMinMax;
905          # Create a table of parameters for each query. Each query looks for features travelling in          # Create a table of parameters for each query. Each query looks for features travelling in
906          # a particular direction. The query parameters include the contig ID, the feature direction,          # a particular direction. The query parameters include the contig ID, the feature direction,
907          # the lowest possible start position, and the highest possible start position. This works          # the lowest possible start position, and the highest possible start position. This works
# Line 892  Line 931 
931                                          $found = 1;                                          $found = 1;
932                                  }                                  }
933                          } elsif ($dir eq '-') {                          } elsif ($dir eq '-') {
934                                  $end = $beg - $len;                  # Note we switch things around so that the beginning is to the left of the
935                                  if ($end <= $stop) {                  # ending.
936                    ($beg, $end) = ($beg - $len, $beg);
937                    if ($beg <= $stop) {
938                                          # Denote we found a useful feature.                                          # Denote we found a useful feature.
939                                          $found = 1;                                          $found = 1;
940                                  }                                  }
941                          }                          }
942                          if ($found) {                          if ($found) {
943                                  # Here we need to record the feature and update the minimum and maximum.                  # Here we need to record the feature and update the minima and maxima. First,
944                                  $featuresFound{$featureID} = 1;                  # get the current entry for the specified feature.
945                                  if ($beg < $min) { $min = $beg; }                  my ($loc1, $loc2) = (exists $featuresFound{$featureID} ? @{$featuresFound{$featureID}} :
946                                  if ($end < $min) { $min = $end; }                                       @initialMinMax);
947                                  if ($beg > $max) { $max = $beg; }                  # Merge the current segment's begin and end into the feature begin and end and the
948                                  if ($end > $max) { $max = $end; }                  # global min and max.
949                    if ($beg < $loc1) {
950                        $loc1 = $beg;
951                        $min = $beg if $beg < $min;
952                    }
953                    if ($end > $loc2) {
954                        $loc2 = $end;
955                        $max = $end if $end > $max;
956                    }
957                    # Store the entry back into the hash table.
958                    $featuresFound{$featureID} = [$loc1, $loc2];
959                          }                          }
960                  }                  }
961          }          }
962          # Compute a list of the IDs for the features found.      # Now we must compute the list of the IDs for the features found. We start with a list
963          my @list = (sort (keys %featuresFound));      # of midpoints / feature ID pairs. (It's not really a midpoint, it's twice the midpoint,
964        # but the result of the sort will be the same.)
965        my @list = map { [$featuresFound{$_}->[0] + $featuresFound{$_}->[1], $_] } keys %featuresFound;
966        # Now we sort by midpoint and yank out the feature IDs.
967        my @retVal = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @list;
968          # Return it along with the min and max.          # Return it along with the min and max.
969          return (\@list, $min, $max);      return (\@retVal, $min, $max);
970  }  }
971    
972  =head3 FType  =head3 FType
# Line 934  Line 989 
989  =back  =back
990    
991  =cut  =cut
992    #: Return Type $;
993  sub FType {  sub FType {
994          # Get the parameters.          # Get the parameters.
995          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
996          # Get the specified feature's type.          # Get the specified feature's type.
997          my ($retVal) = $self->GetEntityValues('Feature', $featureID, ['Feature(feature-type)']);          my ($retVal) = $self->GetEntityValues('Feature', $featureID, ['Feature(feature-type)']);
998          # Return the result.          # Return the result.
# Line 963  Line 1017 
1017    
1018  * B<featureID> ID of the relevant feature.  * B<featureID> ID of the relevant feature.
1019    
1020  * B<timeStamp> time the annotation was made.  * B<timeStamp> time the annotation was made, in user-friendly format.
1021    
1022  * B<user> ID of the user who made the annotation  * B<user> ID of the user who made the annotation
1023    
# Line 972  Line 1026 
1026  =back  =back
1027    
1028  =cut  =cut
1029    #: Return Type @%;
1030  sub FeatureAnnotations {  sub FeatureAnnotations {
1031          # Get the parameters.          # Get the parameters.
1032          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1033          # Create a query to get the feature's annotations and the associated users.          # Create a query to get the feature's annotations and the associated users.
1034          my $query = $self->Get(['IsTargetOfAnnotation', 'Annotation', 'MadeAnnotation'],          my $query = $self->Get(['IsTargetOfAnnotation', 'Annotation', 'MadeAnnotation'],
1035                                                     "IsTargetOfAnnotation(from-link) = ?", [$featureID]);                                                     "IsTargetOfAnnotation(from-link) = ?", [$featureID]);
# Line 990  Line 1043 
1043                                                                   'Annotation(time)', 'MadeAnnotation(from-link)',                                                                   'Annotation(time)', 'MadeAnnotation(from-link)',
1044                                                                   'Annotation(annotation)']);                                                                   'Annotation(annotation)']);
1045                  # Assemble them into a hash.                  # Assemble them into a hash.
1046                  my $annotationHash = { featureID => $featureID, timeStamp => $timeStamp,          my $annotationHash = { featureID => $featureID,
1047                                   timeStamp => FriendlyTimestamp($timeStamp),
1048                                                             user => $user, text => $text };                                                             user => $user, text => $text };
1049                  # Add it to the return list.                  # Add it to the return list.
1050                  push @retVal, $annotationHash;                  push @retVal, $annotationHash;
# Line 1004  Line 1058 
1058  C<< my %functions = $sprout->AllFunctionsOf($featureID); >>  C<< my %functions = $sprout->AllFunctionsOf($featureID); >>
1059    
1060  Return all of the functional assignments for a particular feature. The data is returned as a  Return all of the functional assignments for a particular feature. The data is returned as a
1061  hash of functional assignments to user IDs. A functional assignment is a type of annotation.  hash of functional assignments to user IDs. A functional assignment is a type of annotation,
1062  It has the format "XXXX\nset XXXX function to\nYYYYY". In this instance, XXXX is the user ID  Functional assignments are described in the L</ParseAssignment> function. Its worth noting that
1063  and YYYYY is the functional assignment text. Its worth noting that we cannot filter on the content  we cannot filter on the content of the annotation itself because it's a text field; however,
1064  of the annotation itself because it's a text field; however, this is not a big problem because most  this is not a big problem because most features only have a small number of annotations.
1065  features only have a small number of annotations.  Finally, if a single user has multiple functional assignments, we will only keep the most
1066    recent one.
1067    
1068  =over 4  =over 4
1069    
# Line 1016  Line 1071 
1071    
1072  ID of the feature whose functional assignments are desired.  ID of the feature whose functional assignments are desired.
1073    
1074    =item RETURN
1075    
1076    Returns a hash mapping the functional assignment IDs to user IDs.
1077    
1078  =back  =back
1079    
1080  =cut  =cut
1081    #: Return Type %;
1082  sub AllFunctionsOf {  sub AllFunctionsOf {
1083          # Get the parameters.          # Get the parameters.
1084          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1085          # Get all of the feature's annotations.          # Get all of the feature's annotations.
1086          my @query = $self->GetFlat(['IsTargetOfAnnotation', 'Annotation'],      my @query = $self->GetAll(['IsTargetOfAnnotation', 'Annotation'],
1087                                                      "IsTargetOfAnnotation(from-link) = ?",                                                      "IsTargetOfAnnotation(from-link) = ?",
1088                                                          [$featureID], 'Annotation(annotation)');                              [$featureID], ['Annotation(time)', 'Annotation(annotation)']);
1089          # Declare the return hash.          # Declare the return hash.
1090          my %retVal;          my %retVal;
1091        # Declare a hash for insuring we only make one assignment per user.
1092        my %timeHash = ();
1093        # Now we sort the assignments by timestamp in reverse.
1094        my @sortedQuery = sort { -($a->[0] <=> $b->[0]) } @query;
1095          # Loop until we run out of annotations.          # Loop until we run out of annotations.
1096          for my $text (@query) {      for my $annotation (@sortedQuery) {
1097            # Get the annotation fields.
1098            my ($timeStamp, $text) = @{$annotation};
1099                  # Check to see if this is a functional assignment.                  # Check to see if this is a functional assignment.
1100                  my ($user, $function) = ParseAssignment($text);          my ($user, $function) = _ParseAssignment($text);
1101                  if ($user) {          if ($user && ! exists $timeHash{$user}) {
1102                          # Here it is, so stuff it in the return hash.              # Here it is a functional assignment and there has been no
1103                # previous assignment for this user, so we stuff it in the
1104                # return hash.
1105                          $retVal{$function} = $user;                          $retVal{$function} = $user;
1106                # Insure we don't assign to this user again.
1107                $timeHash{$user} = 1;
1108                  }                  }
1109          }          }
1110          # Return the hash of assignments found.          # Return the hash of assignments found.
# Line 1047  Line 1115 
1115    
1116  C<< my $functionText = $sprout->FunctionOf($featureID, $userID); >>  C<< my $functionText = $sprout->FunctionOf($featureID, $userID); >>
1117    
1118  Return the most recently-determined functional assignment of a particular feature. A functional  Return the most recently-determined functional assignment of a particular feature.
1119  assignment is a type of annotation. It has the format "XXXX\nset XXXX function to\nYYYYY". In this  
1120  instance, XXXX is the user ID and YYYYY is the functional assignment text. Its worth noting that  The functional assignment is handled differently depending on the type of feature. If
1121  we cannot filter on the content of the annotation itself because it's a text field; however, this  the feature is identified by a FIG ID (begins with the string C<fig|>), then a functional
1122  is not a big problem because most features only have a small number of annotations.  assignment is a type of annotation. The format of an assignment is described in
1123    L</ParseLocation>. Its worth noting that we cannot filter on the content of the
1124    annotation itself because it's a text field; however, this is not a big problem because
1125    most features only have a small number of annotations.
1126    
1127    Each user has an associated list of trusted users. The assignment returned will be the most
1128    recent one by at least one of the trusted users. If no trusted user list is available, then
1129    the specified user and FIG are considered trusted. If the user ID is omitted, only FIG
1130    is trusted.
1131    
1132    If the feature is B<not> identified by a FIG ID, then the functional assignment
1133    information is taken from the B<ExternalAliasFunc> table. If the table does
1134    not contain an entry for the feature, an undefined value is returned.
1135    
1136  =over 4  =over 4
1137    
# Line 1061  Line 1141 
1141    
1142  =item userID (optional)  =item userID (optional)
1143    
1144  ID of the user whose function determination is desired. If omitted, C<FIG> is assumed.  ID of the user whose function determination is desired. If omitted, only the latest
1145    C<FIG> assignment will be returned.
1146    
1147  =item RETURN  =item RETURN
1148    
# Line 1070  Line 1151 
1151  =back  =back
1152    
1153  =cut  =cut
1154    #: Return Type $;
1155  sub FunctionOf {  sub FunctionOf {
1156          # Get the parameters.          # Get the parameters.
1157          my $self = shift @_;      my ($self, $featureID, $userID) = @_;
1158          my ($featureID, $userID) = @_;      # Declare the return value.
         if (!$userID) { $userID = 'FIG'; }  
         # Build a query for all of the feature's annotation, sorted by date.  
         my $query = $self->Get(['IsTargetOfAnnotation', 'Annotation'],  
                                                     "IsTargetOfAnnotation(from-link) = ?", [$featureID]);  
         # Declare the return value. We'll set this to the most recent annotation for the  
         # specified user.  
1159          my $retVal;          my $retVal;
1160        # Determine the ID type.
1161        if ($featureID =~ m/^fig\|/) {
1162            # Here we have a FIG feature ID. We must build the list of trusted
1163            # users.
1164            my %trusteeTable = ();
1165            # Check the user ID.
1166            if (!$userID) {
1167                # No user ID, so only FIG is trusted.
1168                $trusteeTable{FIG} = 1;
1169            } else {
1170                # Add this user's ID.
1171                $trusteeTable{$userID} = 1;
1172                # Look for the trusted users in the database.
1173                my @trustees = $self->GetFlat(['IsTrustedBy'], 'IsTrustedBy(from-link) = ?', [$userID], 'IsTrustedBy(to-link)');
1174                if (! @trustees) {
1175                    # None were found, so build a default list.
1176                    $trusteeTable{FIG} = 1;
1177                } else {
1178                    # Otherwise, put all the trustees in.
1179                    for my $trustee (@trustees) {
1180                        $trusteeTable{$trustee} = 1;
1181                    }
1182                }
1183            }
1184            # Build a query for all of the feature's annotations, sorted by date.
1185            my $query = $self->Get(['IsTargetOfAnnotation', 'Annotation'],
1186                                   "IsTargetOfAnnotation(from-link) = ? ORDER BY Annotation(time) DESC",
1187                                   [$featureID]);
1188          my $timeSelected = 0;          my $timeSelected = 0;
1189          # Loop until we run out of annotations.          # Loop until we run out of annotations.
1190          while (my $annotation = $query->Fetch()) {          while (my $annotation = $query->Fetch()) {
1191                  # Get the annotation text.                  # Get the annotation text.
1192                  my ($text, $time) = $annotation->Values(['Annotation(annotation)','Annotation(time)']);                  my ($text, $time) = $annotation->Values(['Annotation(annotation)','Annotation(time)']);
1193                  # Check to see if this is a functional assignment for the desired user.              # Check to see if this is a functional assignment for a trusted user.
1194                  my ($user, $type, $function) = split(/\n/, $text);              my ($user, $function) = _ParseAssignment($text);
1195                  if ($type =~ m/^set $userID function to$/i) {              if ($user) {
1196                          # Here it is, so we check the time and save the assignment value.                  # Here it is a functional assignment. Check the time and the user
1197                          if ($time > $timeSelected) {                  # name. The time must be recent and the user must be trusted.
1198                    if ((exists $trusteeTable{$user}) && ($time > $timeSelected)) {
1199                                  $retVal = $function;                                  $retVal = $function;
1200                                  $timeSelected = $time;                                  $timeSelected = $time;
1201                          }                          }
1202                  }                  }
1203          }          }
1204        } else {
1205            # Here we have a non-FIG feature ID. In this case the user ID does not
1206            # matter. We simply get the information from the External Alias Function
1207            # table.
1208            ($retVal) = $self->GetEntityValues('ExternalAliasFunc', $featureID, ['ExternalAliasFunc(func)']);
1209        }
1210          # Return the assignment found.          # Return the assignment found.
1211          return $retVal;          return $retVal;
1212  }  }
# Line 1120  Line 1230 
1230    
1231  =item RETURN  =item RETURN
1232    
1233  Returns a reference to a hash that maps the IDs of the incoming features to the IDs of  Returns a reference to a hash that maps the IDs of the incoming features to the best hits
1234  their best hits.  on the target genome.
1235    
1236  =back  =back
1237    
1238  =cut  =cut
1239    #: Return Type %;
1240  sub BBHList {  sub BBHList {
1241          # Get the parameters.          # Get the parameters.
1242          my $self = shift @_;      my ($self, $genomeID, $featureList) = @_;
         my ($genomeID, $featureList) = @_;  
1243          # Create the return structure.          # Create the return structure.
1244          my %retVal = ();          my %retVal = ();
1245          # Loop through the incoming features.          # Loop through the incoming features.
# Line 1150  Line 1259 
1259          return \%retVal;          return \%retVal;
1260  }  }
1261    
1262    =head3 SimList
1263    
1264    C<< my %similarities = $sprout->SimList($featureID, $count); >>
1265    
1266    Return a list of the similarities to the specified feature.
1267    
1268    Sprout does not support real similarities, so this method just returns the bidirectional
1269    best hits.
1270    
1271    =over 4
1272    
1273    =item featureID
1274    
1275    ID of the feature whose similarities are desired.
1276    
1277    =item count
1278    
1279    Maximum number of similar features to be returned, or C<0> to return them all.
1280    
1281    =back
1282    
1283    =cut
1284    #: Return Type %;
1285    sub SimList {
1286        # Get the parameters.
1287        my ($self, $featureID, $count) = @_;
1288        # Ask for the best hits.
1289        my @lists = $self->GetAll(['IsBidirectionalBestHitOf'],
1290                                  "IsBidirectionalBestHitOf(from-link) = ? ORDER BY IsBidirectionalBestHitOf(score) DESC",
1291                                  [$featureID], ['IsBidirectionalBestHitOf(to-link)', 'IsBidirectionalBestHitOf(score)'],
1292                                  $count);
1293        # Create the return value.
1294        my %retVal = ();
1295        for my $tuple (@lists) {
1296            $retVal{$tuple->[0]} = $tuple->[1];
1297        }
1298        # Return the result.
1299        return %retVal;
1300    }
1301    
1302    
1303    
1304    =head3 IsComplete
1305    
1306    C<< my $flag = $sprout->IsComplete($genomeID); >>
1307    
1308    Return TRUE if the specified genome is complete, else FALSE.
1309    
1310    =over 4
1311    
1312    =item genomeID
1313    
1314    ID of the genome whose completeness status is desired.
1315    
1316    =item RETURN
1317    
1318    Returns TRUE if the genome is complete, FALSE if it is incomplete, and C<undef> if it is
1319    not found.
1320    
1321    =back
1322    
1323    =cut
1324    #: Return Type $;
1325    sub IsComplete {
1326        # Get the parameters.
1327        my ($self, $genomeID) = @_;
1328        # Declare the return variable.
1329        my $retVal;
1330        # Get the genome's data.
1331        my $genomeData = $self->GetEntity('Genome', $genomeID);
1332        if ($genomeData) {
1333            # The genome exists, so get the completeness flag.
1334            ($retVal) = $genomeData->Value('complete');
1335        }
1336        # Return the result.
1337        return $retVal;
1338    }
1339    
1340  =head3 FeatureAliases  =head3 FeatureAliases
1341    
1342  C<< my @aliasList = $sprout->FeatureAliases($featureID); >>  C<< my @aliasList = $sprout->FeatureAliases($featureID); >>
# Line 1170  Line 1357 
1357  =back  =back
1358    
1359  =cut  =cut
1360    #: Return Type @;
1361  sub FeatureAliases {  sub FeatureAliases {
1362          # Get the parameters.          # Get the parameters.
1363          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1364          # Get the desired feature's aliases          # Get the desired feature's aliases
1365          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(alias)']);          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(alias)']);
1366          # Return the result.          # Return the result.
# Line 1201  Line 1387 
1387  =back  =back
1388    
1389  =cut  =cut
1390    #: Return Type $;
1391  sub GenomeOf {  sub GenomeOf {
1392          # Get the parameters.          # Get the parameters.
1393          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
1394          # Create a query to find the genome associated with the feature.          # Create a query to find the genome associated with the feature.
1395          my $query = $self->Get(['IsLocatedIn', 'HasContig'], "IsLocatedIn(from-link) = ?", [$featureID]);          my $query = $self->Get(['IsLocatedIn', 'HasContig'], "IsLocatedIn(from-link) = ?", [$featureID]);
1396          # Declare the return value.          # Declare the return value.
# Line 1238  Line 1423 
1423  =back  =back
1424    
1425  =cut  =cut
1426    #: Return Type %;
1427  sub CoupledFeatures {  sub CoupledFeatures {
1428          # Get the parameters.          # Get the parameters.
1429          my $self = shift @_;      my ($self, $featureID) = @_;
1430          my ($featureID) = @_;      # Create a query to retrieve the functionally-coupled features.
1431          # Create a query to retrieve the functionally-coupled features. Note that we depend on the      my $query = $self->Get(['ParticipatesInCoupling', 'Coupling'],
1432          # fact that the functional coupling is physically paired. If (A,B) is in the database, then                             "ParticipatesInCoupling(from-link) = ?", [$featureID]);
         # (B,A) will also be found.  
         my $query = $self->Get(['IsClusteredOnChromosomeWith'],  
                                                    "IsClusteredOnChromosomeWith(from-link) = ?", [$featureID]);  
1433          # This value will be set to TRUE if we find at least one coupled feature.          # This value will be set to TRUE if we find at least one coupled feature.
1434          my $found = 0;          my $found = 0;
1435          # Create the return hash.          # Create the return hash.
1436          my %retVal = ();          my %retVal = ();
1437          # Retrieve the relationship records and store them in the hash.          # Retrieve the relationship records and store them in the hash.
1438          while (my $clustering = $query->Fetch()) {          while (my $clustering = $query->Fetch()) {
1439                  my ($otherFeatureID, $score) = $clustering->Values(['IsClusteredOnChromosomeWith(to-link)',          # Get the ID and score of the coupling.
1440                                                                      'IsClusteredOnChromosomeWith(score)']);          my ($couplingID, $score) = $clustering->Values(['Coupling(id)',
1441                                                            'Coupling(score)']);
1442            # The coupling ID contains the two feature IDs separated by a space. We use
1443            # this information to find the ID of the other feature.
1444            my ($fid1, $fid2) = split / /, $couplingID;
1445            my $otherFeatureID = ($featureID eq $fid1 ? $fid2 : $fid1);
1446            # Attach the other feature's score to its ID.
1447                  $retVal{$otherFeatureID} = $score;                  $retVal{$otherFeatureID} = $score;
1448                  $found = 1;                  $found = 1;
1449          }          }
# Line 1268  Line 1456 
1456          return %retVal;          return %retVal;
1457  }  }
1458    
1459    =head3 CouplingEvidence
1460    
1461    C<< my @evidence = $sprout->CouplingEvidence($peg1, $peg2); >>
1462    
1463    Return the evidence for a functional coupling.
1464    
1465    A pair of features is considered evidence of a coupling between two other
1466    features if they occur close together on a contig and both are similar to
1467    the coupled features. So, if B<A1> and B<A2> are close together on a contig,
1468    B<B1> and B<B2> are considered evidence for the coupling if (1) B<B1> and
1469    B<B2> are close together, (2) B<B1> is similar to B<A1>, and (3) B<B2> is
1470    similar to B<A2>.
1471    
1472    The score of a coupling is determined by the number of pieces of evidence
1473    that are considered I<representative>. If several evidence items belong to
1474    a group of genomes that are close to each other, only one of those items
1475    is considered representative. The other evidence items are presumed to be
1476    there because of the relationship between the genomes rather than because
1477    the two proteins generated by the features have a related functionality.
1478    
1479    Each evidence item is returned as a three-tuple in the form C<[>I<$peg1a>C<,>
1480    I<$peg2a>C<,> I<$rep>C<]>, where I<$peg1a> is similar to I<$peg1>, I<$peg2a>
1481    is similar to I<$peg2>, and I<$rep> is TRUE if the evidence is representative
1482    and FALSE otherwise.
1483    
1484    =over 4
1485    
1486    =item peg1
1487    
1488    ID of the feature of interest.
1489    
1490    =item peg2
1491    
1492    ID of a feature functionally coupled to the feature of interest.
1493    
1494    =item RETURN
1495    
1496    Returns a list of 3-tuples. Each tuple consists of a feature similar to the feature
1497    of interest, a feature similar to the functionally coupled feature, and a flag
1498    that is TRUE for a representative piece of evidence and FALSE otherwise.
1499    
1500    =back
1501    
1502    =cut
1503    #: Return Type @@;
1504    sub CouplingEvidence {
1505        # Get the parameters.
1506        my ($self, $peg1, $peg2) = @_;
1507        # Declare the return variable.
1508        my @retVal = ();
1509        # Our first task is to find out the nature of the coupling.
1510        my ($couplingID, $inverted, $score) = $self->GetCoupling($peg1, $peg2);
1511        # Only proceed if a coupling exists.
1512        if ($couplingID) {
1513            # Determine the ordering to place on the evidence items. If we're
1514            # inverted, we want to see feature 2 before feature 1; otherwise,
1515            # we want the reverse.
1516            my $ordering = ($inverted ? "DESC" : "");
1517            # Get the coupling evidence.
1518            my @evidenceList = $self->GetAll(['IsEvidencedBy', 'PCH', 'UsesAsEvidence'],
1519                                              "IsEvidencedBy(from-link) = ? ORDER BY PCH(id), UsesAsEvidence(pos) $ordering",
1520                                              [$couplingID],
1521                                              ['PCH(used)', 'UsesAsEvidence(pos)']);
1522            # Loop through the evidence items. Each piece of evidence is represented by two
1523            # positions in the evidence list, one for each feature on the other side of the
1524            # evidence link. If at some point we want to generalize to couplings with
1525            # more than two positions, this section of code will need to be re-done.
1526            while (@evidenceList > 0) {
1527                my $peg1Data = shift @evidenceList;
1528                my $peg2Data = shift @evidenceList;
1529                push @retVal, [$peg1Data->[1], $peg2Data->[1], $peg1Data->[0]];
1530            }
1531        }
1532        # TODO: code
1533        # Return the result.
1534        return @retVal;
1535    }
1536    
1537    =head3 GetCoupling
1538    
1539    C<< my ($couplingID, $inverted, $score) = $sprout->GetCoupling($peg1, $peg2); >>
1540    
1541    Return the coupling (if any) for the specified pair of PEGs. If a coupling
1542    exists, we return the coupling ID along with an indicator of whether the
1543    coupling is stored as C<(>I<$peg1>C<, >I<$peg2>C<)> or C<(>I<$peg2>C<, >I<$peg1>C<)>.
1544    In the second case, we say the coupling is I<inverted>. The importance of an
1545    inverted coupling is that the PEGs in the evidence will appear in reverse order.
1546    
1547    =over 4
1548    
1549    =item peg1
1550    
1551    ID of the feature of interest.
1552    
1553    =item peg2
1554    
1555    ID of the potentially coupled feature.
1556    
1557    =item RETURN
1558    
1559    Returns a three-element list. The first element contains the database ID of
1560    the coupling. The second element is FALSE if the coupling is stored in the
1561    database in the caller specified order and TRUE if it is stored in the
1562    inverted order. The third element is the coupling's score. If the coupling
1563    does not exist, all three list elements will be C<undef>.
1564    
1565    =back
1566    
1567    =cut
1568    #: Return Type $%@;
1569    sub GetCoupling {
1570        # Get the parameters.
1571        my ($self, $peg1, $peg2) = @_;
1572        # Declare the return values. We'll start with the coupling ID and undefine the
1573        # flag and score until we have more information.
1574        my ($retVal, $inverted, $score) = (CouplingID($peg1, $peg2), undef, undef);
1575        # Find the coupling data.
1576        my @pegs = $self->GetAll(['Coupling', 'ParticipatesInCoupling'],
1577                                     "Coupling(id) = ? ORDER BY ParticipatesInCoupling(pos)",
1578                                     [$retVal], "ParticipatesInCoupling(from-link), Coupling(score)");
1579        # Check to see if we found anything.
1580        if (!@pegs) {
1581            # No coupling, so undefine the return value.
1582            $retVal = undef;
1583        } else {
1584            # We have a coupling! Get the score and check for inversion.
1585            $score = $pegs[0]->[1];
1586            $inverted = ($pegs[0]->[0] eq $peg1);
1587        }
1588        # Return the result.
1589        return ($retVal, $inverted, $score);
1590    }
1591    
1592    =head3 CouplingID
1593    
1594    C<< my $couplingID = Sprout::CouplingID($peg1, $peg2); >>
1595    
1596    Return the coupling ID for a pair of feature IDs.
1597    
1598    The coupling ID is currently computed by joining the feature IDs in
1599    sorted order with a space. Client modules (that is, modules which
1600    use Sprout) should not, however, count on this always being the
1601    case. This method provides a way for abstracting the concept of a
1602    coupling ID. All that we know for sure about it is that it can be
1603    generated easily from the feature IDs and the order of the IDs
1604    in the parameter list does not matter (i.e. C<CouplingID("a1", "b1")>
1605    will have the same value as C<CouplingID("b1", "a1")>.
1606    
1607    =over 4
1608    
1609    =item peg1
1610    
1611    First feature of interest.
1612    
1613    =item peg2
1614    
1615    Second feature of interest.
1616    
1617    =item RETURN
1618    
1619    Returns the ID that would be used to represent a functional coupling of
1620    the two specified PEGs.
1621    
1622    =back
1623    
1624    =cut
1625    #: Return Type $;
1626    sub CouplingID {
1627        return join " ", sort @_;
1628    }
1629    
1630  =head3 GetEntityTypes  =head3 GetEntityTypes
1631    
1632  C<< my @entityList = $sprout->GetEntityTypes(); >>  C<< my @entityList = $sprout->GetEntityTypes(); >>
# Line 1275  Line 1634 
1634  Return the list of supported entity types.  Return the list of supported entity types.
1635    
1636  =cut  =cut
1637    #: Return Type @;
1638  sub GetEntityTypes {  sub GetEntityTypes {
1639          # Get the parameters.          # Get the parameters.
1640          my $self = shift @_;      my ($self) = @_;
1641          # Get the underlying database object.          # Get the underlying database object.
1642          my $erdb = $self->{_erdb};          my $erdb = $self->{_erdb};
1643          # Get its entity type list.          # Get its entity type list.
# Line 1310  Line 1669 
1669  =back  =back
1670    
1671  =cut  =cut
1672    #: Return Type %;
1673  sub ReadFasta {  sub ReadFasta {
1674          # Get the parameters.          # Get the parameters.
1675          my ($fileName, $prefix) = @_;          my ($fileName, $prefix) = @_;
# Line 1329  Line 1688 
1688                  if ($line =~ m/^>\s*(.+?)(\s|\n)/) {                  if ($line =~ m/^>\s*(.+?)(\s|\n)/) {
1689                          # Here we have a new header. Store the current sequence if we have one.                          # Here we have a new header. Store the current sequence if we have one.
1690                          if ($id) {                          if ($id) {
1691                                  $retVal{$id} = $sequence;                  $retVal{$id} = uc $sequence;
1692                          }                          }
1693                          # Clear the sequence accumulator and save the new ID.                          # Clear the sequence accumulator and save the new ID.
1694                          ($id, $sequence) = ("$prefix$1", "");                          ($id, $sequence) = ("$prefix$1", "");
1695                  } else {                  } else {
1696                          # Here we have a data line, so we add it to the sequence accumulator.                          # Here we have a data line, so we add it to the sequence accumulator.
1697                          # First, we get the actual data out.              # First, we get the actual data out. Note that we normalize to upper
1698                # case.
1699                          $line =~ /^\s*(.*?)(\s|\n)/;                          $line =~ /^\s*(.*?)(\s|\n)/;
1700                          $sequence .= $1;                          $sequence .= $1;
1701                  }                  }
1702          }          }
1703          # Flush out the last sequence (if any).          # Flush out the last sequence (if any).
1704          if ($sequence) {          if ($sequence) {
1705                  $retVal {$id} = $sequence;          $retVal{$id} = uc $sequence;
1706          }          }
1707        # Close the file.
1708        close FASTAFILE;
1709          # Return the hash constructed from the file.          # Return the hash constructed from the file.
1710          return %retVal;          return %retVal;
1711  }  }
# Line 1354  Line 1716 
1716    
1717  Insure that a list of feature locations is in the Sprout format. The Sprout feature location  Insure that a list of feature locations is in the Sprout format. The Sprout feature location
1718  format is I<contig>_I<beg*len> where I<*> is C<+> for a forward gene and C<-> for a backward  format is I<contig>_I<beg*len> where I<*> is C<+> for a forward gene and C<-> for a backward
1719  gene. The old format is I<contig>_I<beg>_I<end>.  gene. The old format is I<contig>_I<beg>_I<end>. If a feature is in the new format already,
1720    it will not be changed; otherwise, it will be converted. This method can also be used to
1721    perform the reverse task-- insuring that all the locations are in the old format.
1722    
1723  =over 4  =over 4
1724    
# Line 1378  Line 1742 
1742  =back  =back
1743    
1744  =cut  =cut
1745    #: Return Type @;
1746  sub FormatLocations {  sub FormatLocations {
1747          # Get the parameters.          # Get the parameters.
1748          my $self = shift @_;      my ($self, $prefix, $locations, $oldFormat) = @_;
         my ($prefix, $locations, $oldFormat) = @_;  
1749          # Create the return list.          # Create the return list.
1750          my @retVal = ();          my @retVal = ();
1751          # Check to see if any locations were passed in.          # Check to see if any locations were passed in.
1752          if ($locations eq '') {          if ($locations eq '') {
1753              confess "No locations specified.";          Confess("No locations specified.");
1754          } else {          } else {
1755                  # Loop through the locations, converting them to the new format.                  # Loop through the locations, converting them to the new format.
1756                  for my $location (@{$locations}) {                  for my $location (@{$locations}) {
# Line 1422  Line 1785 
1785    
1786  sub DumpData {  sub DumpData {
1787          # Get the parameters.          # Get the parameters.
1788          my $self = shift @_;      my ($self) = @_;
1789          # Get the data directory name.          # Get the data directory name.
1790          my $outputDirectory = $self->{_options}->{dataDir};          my $outputDirectory = $self->{_options}->{dataDir};
1791          # Dump the relations.          # Dump the relations.
# Line 1436  Line 1799 
1799  Return the name of this database's XML definition file.  Return the name of this database's XML definition file.
1800    
1801  =cut  =cut
1802    #: Return Type $;
1803  sub XMLFileName {  sub XMLFileName {
1804          my $self = shift @_;      my ($self) = @_;
1805          return $self->{_xmlName};          return $self->{_xmlName};
1806  }  }
1807    
# Line 1458  Line 1821 
1821  The next statement inserts a C<HasProperty> relationship between feature C<fig|158879.1.peg.1> and  The next statement inserts a C<HasProperty> relationship between feature C<fig|158879.1.peg.1> and
1822  property C<4> with an evidence URL of C<http://seedu.uchicago.edu/query.cgi?article_id=142>.  property C<4> with an evidence URL of C<http://seedu.uchicago.edu/query.cgi?article_id=142>.
1823    
1824  C<< $sprout->InsertObject('HasProperty', { 'from-link' => 'fig|158879.1.peg.1', 'to-link' => 4, evidence = 'http://seedu.uchicago.edu/query.cgi?article_id=142'}); >>  C<< $sprout->InsertObject('HasProperty', { 'from-link' => 'fig|158879.1.peg.1', 'to-link' => 4, evidence => 'http://seedu.uchicago.edu/query.cgi?article_id=142'}); >>
1825    
1826  =over 4  =over 4
1827    
# Line 1473  Line 1836 
1836  =back  =back
1837    
1838  =cut  =cut
1839    #: Return Type ;
1840  sub Insert {  sub Insert {
1841          # Get the parameters.          # Get the parameters.
1842          my $self = shift @_;      my ($self, $objectType, $fieldHash) = @_;
         my ($objectType, $fieldHash) = @_;  
1843          # Call the underlying method.          # Call the underlying method.
1844          $self->{_erdb}->InsertObject($objectType, $fieldHash);          $self->{_erdb}->InsertObject($objectType, $fieldHash);
1845  }  }
# Line 1515  Line 1877 
1877  =back  =back
1878    
1879  =cut  =cut
1880    #: Return Type $;
1881  sub Annotate {  sub Annotate {
1882          # Get the parameters.          # Get the parameters.
1883          my $self = shift @_;      my ($self, $fid, $timestamp, $user, $text) = @_;
         my ($fid, $timestamp, $user, $text) = @_;  
1884          # Create the annotation ID.          # Create the annotation ID.
1885          my $aid = "$fid:$timestamp";          my $aid = "$fid:$timestamp";
1886          # Insert the Annotation object.          # Insert the Annotation object.
# Line 1539  Line 1900 
1900    
1901  =head3 AssignFunction  =head3 AssignFunction
1902    
1903  C<< my $ok = $sprout->AssignFunction($featureID, $user, $function); >>  C<< my $ok = $sprout->AssignFunction($featureID, $user, $function, $assigningUser); >>
1904    
1905  This method assigns a function to a feature. Functions are a special type of annotation. The general  This method assigns a function to a feature. Functions are a special type of annotation. The general
1906  format is "XXXX\nset XXXX function to\nYYYYY" where XXXX is the feature type and YYYY is the functional  format is described in L</ParseAssignment>.
 assignment text.  
1907    
1908  =over 4  =over 4
1909    
# Line 1553  Line 1913 
1913    
1914  =item user  =item user
1915    
1916  Name of the user making the assignment. This is frequently a group name, like C<kegg> or C<fig>.  Name of the user group making the assignment, such as C<kegg> or C<fig>.
1917    
1918  =item function  =item function
1919    
1920  Text of the function being assigned.  Text of the function being assigned.
1921    
1922    =item assigningUser (optional)
1923    
1924    Name of the individual user making the assignment. If omitted, defaults to the user group.
1925    
1926  =item RETURN  =item RETURN
1927    
1928  Returns 1 if successful, 0 if an error occurred.  Returns 1 if successful, 0 if an error occurred.
# Line 1566  Line 1930 
1930  =back  =back
1931    
1932  =cut  =cut
1933    #: Return Type $;
1934  sub AssignFunction {  sub AssignFunction {
1935          # Get the parameters.          # Get the parameters.
1936          my $self = shift @_;      my ($self, $featureID, $user, $function, $assigningUser) = @_;
1937          my ($featureID, $user, $function) = @_;      # Default the assigning user.
1938        if (! $assigningUser) {
1939            $assigningUser = $user;
1940        }
1941          # Create an annotation string from the parameters.          # Create an annotation string from the parameters.
1942          my $annotationText = "$user\nset $user function to\n$function";      my $annotationText = "$assigningUser\nset $user function to\n$function";
1943          # Get the current time.          # Get the current time.
1944          my $now = time;          my $now = time;
1945          # Declare the return variable.          # Declare the return variable.
# Line 1614  Line 1981 
1981  =back  =back
1982    
1983  =cut  =cut
1984    #: Return Type @;
1985  sub FeaturesByAlias {  sub FeaturesByAlias {
1986          # Get the parameters.          # Get the parameters.
1987          my $self = shift @_;      my ($self, $alias) = @_;
         my ($alias) = @_;  
1988          # Declare the return variable.          # Declare the return variable.
1989          my @retVal = ();          my @retVal = ();
1990          # Parse the alias.          # Parse the alias.
# Line 1657  Line 2023 
2023  =back  =back
2024    
2025  =cut  =cut
2026    #: Return Type $;
2027  sub Exists {  sub Exists {
2028          # Get the parameters.          # Get the parameters.
2029          my $self = shift @_;      my ($self, $entityName, $entityID) = @_;
         my ($entityName, $entityID) = @_;  
2030          # Check for the entity instance.          # Check for the entity instance.
2031          my $testInstance = $self->GetEntity($entityName, $entityID);          my $testInstance = $self->GetEntity($entityName, $entityID);
2032          # Return an existence indicator.          # Return an existence indicator.
# Line 1688  Line 2053 
2053  =back  =back
2054    
2055  =cut  =cut
2056    #: Return Type $;
2057  sub FeatureTranslation {  sub FeatureTranslation {
2058          # Get the parameters.          # Get the parameters.
2059          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
2060          # Get the specified feature's translation.          # Get the specified feature's translation.
2061          my ($retVal) = $self->GetEntityValues("Feature", $featureID, ['Feature(translation)']);          my ($retVal) = $self->GetEntityValues("Feature", $featureID, ['Feature(translation)']);
2062          return $retVal;          return $retVal;
# Line 1721  Line 2085 
2085  =back  =back
2086    
2087  =cut  =cut
2088    #: Return Type @;
2089  sub Taxonomy {  sub Taxonomy {
2090          # Get the parameters.          # Get the parameters.
2091          my $self = shift @_;      my ($self, $genome) = @_;
         my ($genome) = @_;  
2092          # Find the specified genome's taxonomy string.          # Find the specified genome's taxonomy string.
2093          my ($list) = $self->GetEntityValues('Genome', $genome, ['Genome(taxonomy)']);          my ($list) = $self->GetEntityValues('Genome', $genome, ['Genome(taxonomy)']);
2094          # Declare the return variable.          # Declare the return variable.
# Line 1765  Line 2128 
2128  =back  =back
2129    
2130  =cut  =cut
2131    #: Return Type $;
2132  sub CrudeDistance {  sub CrudeDistance {
2133          # Get the parameters.          # Get the parameters.
2134          my $self = shift @_;      my ($self, $genome1, $genome2) = @_;
         my ($genome1, $genome2) = @_;  
2135          # Insure that the distance is commutative by sorting the genome IDs.          # Insure that the distance is commutative by sorting the genome IDs.
2136          my ($genomeA, $genomeB);          my ($genomeA, $genomeB);
2137          if ($genome2 < $genome2) {          if ($genome2 < $genome2) {
# Line 1813  Line 2175 
2175  =back  =back
2176    
2177  =cut  =cut
2178    #: Return Type $;
2179  sub RoleName {  sub RoleName {
2180          # Get the parameters.          # Get the parameters.
2181          my $self = shift @_;      my ($self, $roleID) = @_;
         my ($roleID) = @_;  
2182          # Get the specified role's name.          # Get the specified role's name.
2183          my ($retVal) = $self->GetEntityValues('Role', $roleID, ['Role(name)']);          my ($retVal) = $self->GetEntityValues('Role', $roleID, ['Role(name)']);
2184          # Use the ID if the role has no name.          # Use the ID if the role has no name.
# Line 1847  Line 2208 
2208  =back  =back
2209    
2210  =cut  =cut
2211    #: Return Type @;
2212  sub RoleDiagrams {  sub RoleDiagrams {
2213          # Get the parameters.          # Get the parameters.
2214          my $self = shift @_;      my ($self, $roleID) = @_;
         my ($roleID) = @_;  
2215          # Query for the diagrams.          # Query for the diagrams.
2216          my @retVal = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],          my @retVal = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],
2217                                                                  'RoleOccursIn(to-link)');                                                                  'RoleOccursIn(to-link)');
# Line 1885  Line 2245 
2245  =back  =back
2246    
2247  =cut  =cut
2248    #: Return Type @@;
2249  sub FeatureProperties {  sub FeatureProperties {
2250          # Get the parameters.          # Get the parameters.
2251          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
2252          # Get the properties.          # Get the properties.
2253          my @retVal = $self->GetAll(['HasProperty', 'Property'], "HasProperty(from-link) = ?", [$featureID],          my @retVal = $self->GetAll(['HasProperty', 'Property'], "HasProperty(from-link) = ?", [$featureID],
2254                                                          ['Property(property-name)', 'Property(property-value)',                                                          ['Property(property-name)', 'Property(property-value)',
# Line 1917  Line 2276 
2276  =back  =back
2277    
2278  =cut  =cut
2279    #: Return Type $;
2280  sub DiagramName {  sub DiagramName {
2281          # Get the parameters.          # Get the parameters.
2282          my $self = shift @_;      my ($self, $diagramID) = @_;
         my ($diagramID) = @_;  
2283          # Get the specified diagram's name and return it.          # Get the specified diagram's name and return it.
2284          my ($retVal) = $self->GetEntityValues('Diagram', $diagramID, ['Diagram(name)']);          my ($retVal) = $self->GetEntityValues('Diagram', $diagramID, ['Diagram(name)']);
2285          return $retVal;          return $retVal;
# Line 1950  Line 2308 
2308  =back  =back
2309    
2310  =cut  =cut
2311    #: Return Type @;
2312  sub MergedAnnotations {  sub MergedAnnotations {
2313          # Get the parameters.          # Get the parameters.
2314          my $self = shift @_;      my ($self, $list) = @_;
         my ($list) = @_;  
2315          # Create a list to hold the annotation tuples found.          # Create a list to hold the annotation tuples found.
2316          my @tuples = ();          my @tuples = ();
2317          # Loop through the features in the input list.          # Loop through the features in the input list.
# Line 1969  Line 2326 
2326          }          }
2327          # Sort the result list by timestamp.          # Sort the result list by timestamp.
2328          my @retVal = sort { $a->[1] <=> $b->[1] } @tuples;          my @retVal = sort { $a->[1] <=> $b->[1] } @tuples;
2329        # Loop through and make the time stamps friendly.
2330        for my $tuple (@retVal) {
2331            $tuple->[1] = FriendlyTimestamp($tuple->[1]);
2332        }
2333          # Return the sorted list.          # Return the sorted list.
2334          return @retVal;          return @retVal;
2335  }  }
# Line 1995  Line 2356 
2356  =back  =back
2357    
2358  =cut  =cut
2359    #: Return Type @;
2360  sub RoleNeighbors {  sub RoleNeighbors {
2361          # Get the parameters.          # Get the parameters.
2362          my $self = shift @_;      my ($self, $roleID) = @_;
         my ($roleID) = @_;  
2363          # Get all the diagrams containing this role.          # Get all the diagrams containing this role.
2364          my @diagrams = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],          my @diagrams = $self->GetFlat(['RoleOccursIn'], "RoleOccursIn(from-link) = ?", [$roleID],
2365                                                                    'RoleOccursIn(to-link)');                                                                    'RoleOccursIn(to-link)');
# Line 2038  Line 2398 
2398  =back  =back
2399    
2400  =cut  =cut
2401    #: Return Type @;
2402  sub FeatureLinks {  sub FeatureLinks {
2403          # Get the parameters.          # Get the parameters.
2404          my $self = shift @_;      my ($self, $featureID) = @_;
         my ($featureID) = @_;  
2405          # Get the feature's links.          # Get the feature's links.
2406          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(link)']);          my @retVal = $self->GetEntityValues('Feature', $featureID, ['Feature(link)']);
2407          # Return the feature's links.          # Return the feature's links.
# Line 2069  Line 2428 
2428  =back  =back
2429    
2430  =cut  =cut
2431    #: Return Type %;
2432  sub SubsystemsOf {  sub SubsystemsOf {
2433          # Get the parameters.          # Get the parameters.
2434          my $self = shift @_;      my ($self, $featureID) = @_;
2435          my ($featureID) = @_;      # Get the subsystem list.
         # Use the SSCell to connect features to subsystems.  
2436          my @subsystems = $self->GetAll(['ContainsFeature', 'HasSSCell', 'IsRoleOf'],          my @subsystems = $self->GetAll(['ContainsFeature', 'HasSSCell', 'IsRoleOf'],
2437                                                                          "ContainsFeature(to-link) = ?", [$featureID],                                                                          "ContainsFeature(to-link) = ?", [$featureID],
2438                                                                          ['HasSSCell(from-link)', 'IsRoleOf(from-link)']);                                                                          ['HasSSCell(from-link)', 'IsRoleOf(from-link)']);
# Line 2088  Line 2446 
2446          return %retVal;          return %retVal;
2447  }  }
2448    
2449    =head3 SubsystemList
2450    
2451    C<< my @subsystems = $sprout->SubsystemList($featureID); >>
2452    
2453    Return a list containing the names of the subsystems in which the specified
2454    feature participates. Unlike L</SubsystemsOf>, this method only returns the
2455    subsystem names, not the roles.
2456    
2457    =over 4
2458    
2459    =item featureID
2460    
2461    ID of the feature whose subsystem names are desired.
2462    
2463    =item RETURN
2464    
2465    Returns a list of the names of the subsystems in which the feature participates.
2466    
2467    =back
2468    
2469    =cut
2470    #: Return Type @;
2471    sub SubsystemList {
2472        # Get the parameters.
2473        my ($self, $featureID) = @_;
2474        # Get the list of names.
2475        my @retVal = $self->GetFlat(['ContainsFeature', 'HasSSCell'], "ContainsFeature(to-link) = ?",
2476                                    [$featureID], 'HasSSCell(from-link)');
2477        # Return the result.
2478        return @retVal;
2479    }
2480    
2481  =head3 RelatedFeatures  =head3 RelatedFeatures
2482    
2483  C<< my @relatedList = $sprout->RelatedFeatures($featureID, $function, $userID); >>  C<< my @relatedList = $sprout->RelatedFeatures($featureID, $function, $userID); >>
# Line 2118  Line 2508 
2508  =back  =back
2509    
2510  =cut  =cut
2511    #: Return Type @;
2512  sub RelatedFeatures {  sub RelatedFeatures {
2513          # Get the parameters.          # Get the parameters.
2514          my $self = shift @_;      my ($self, $featureID, $function, $userID) = @_;
         my ($featureID, $function, $userID) = @_;  
2515          # Get a list of the features that are BBHs of the incoming feature.          # Get a list of the features that are BBHs of the incoming feature.
2516          my @bbhFeatures = $self->GetFlat(['IsBidirectionalBestHitOf'],          my @bbhFeatures = $self->GetFlat(['IsBidirectionalBestHitOf'],
2517                                                                           "IsBidirectionalBestHitOf(from-link) = ?", [$featureID],                                                                           "IsBidirectionalBestHitOf(from-link) = ?", [$featureID],
# Line 2167  Line 2556 
2556  =back  =back
2557    
2558  =cut  =cut
2559    #: Return Type @;
2560  sub TaxonomySort {  sub TaxonomySort {
2561          # Get the parameters.          # Get the parameters.
2562          my $self = shift @_;      my ($self, $featureIDs) = @_;
         my ($featureIDs) = @_;  
2563          # Create the working hash table.          # Create the working hash table.
2564          my %hashBuffer = ();          my %hashBuffer = ();
2565          # Loop through the features.          # Loop through the features.
# Line 2180  Line 2568 
2568                  my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",                  my ($taxonomy) = $self->GetFlat(['IsLocatedIn', 'HasContig', 'Genome'], "IsLocatedIn(from-link) = ?",
2569                                                                                  [$fid], 'Genome(taxonomy)');                                                                                  [$fid], 'Genome(taxonomy)');
2570                  # Add this feature to the hash buffer.                  # Add this feature to the hash buffer.
2571                  if (exists $hashBuffer{$taxonomy}) {          Tracer::AddToListMap(\%hashBuffer, $taxonomy, $fid);
                         push @{$hashBuffer{$taxonomy}}, $fid;  
                 } else {  
                         $hashBuffer{$taxonomy} = [$fid];  
                 }  
2572          }          }
2573          # Sort the keys and get the elements.          # Sort the keys and get the elements.
2574          my @retVal = ();          my @retVal = ();
# Line 2250  Line 2634 
2634  =back  =back
2635    
2636  =cut  =cut
2637    #: Return Type @@;
2638  sub GetAll {  sub GetAll {
2639          # Get the parameters.          # Get the parameters.
2640          my $self = shift @_;      my ($self, $objectNames, $filterClause, $parameterList, $fields, $count) = @_;
2641          my ($objectNames, $filterClause, $parameterList, $fields, $count) = @_;      # Call the ERDB method.
2642          # Create the query.      my @retVal = $self->{_erdb}->GetAll($objectNames, $filterClause, $parameterList,
2643          my $query = $self->Get($objectNames, $filterClause, $parameterList);                                          $fields, $count);
         # Set up a counter of the number of records read.  
         my $fetched = 0;  
         # Insure the counter has a value.  
         if (!defined $count) {  
                 $count = 0;  
         }  
         # Loop through the records returned, extracting the fields. Note that if the  
         # counter is non-zero, we stop when the number of records read hits the count.  
         my @retVal = ();  
         while (($count == 0 || $fetched < $count) && (my $row = $query->Fetch())) {  
                 my @rowData = $row->Values($fields);  
                 push @retVal, \@rowData;  
                 $fetched++;  
         }  
2644          # Return the resulting list.          # Return the resulting list.
2645          return @retVal;          return @retVal;
2646  }  }
# Line 2312  Line 2682 
2682  =back  =back
2683    
2684  =cut  =cut
2685    #: Return Type @;
2686  sub GetFlat {  sub GetFlat {
2687          # Get the parameters.          # Get the parameters.
2688          my $self = shift @_;      my ($self, $objectNames, $filterClause, $parameterList, $field) = @_;
         my ($objectNames, $filterClause, $parameterList, $field) = @_;  
2689          # Construct the query.          # Construct the query.
2690          my $query = $self->Get($objectNames, $filterClause, $parameterList);          my $query = $self->Get($objectNames, $filterClause, $parameterList);
2691          # Create the result list.          # Create the result list.
# Line 2423  Line 2792 
2792  to load the entire database.  to load the entire database.
2793    
2794  =cut  =cut
2795    #: Return Type @;
2796  sub LoadInfo {  sub LoadInfo {
2797          # Get the parameters.          # Get the parameters.
2798          my $self = shift @_;      my ($self) = @_;
2799          # Create the return list, priming it with the name of the data directory.          # Create the return list, priming it with the name of the data directory.
2800          my @retVal = ($self->{_options}->{dataDir});          my @retVal = ($self->{_options}->{dataDir});
2801          # Concatenate the table names.          # Concatenate the table names.
# Line 2460  Line 2829 
2829  =back  =back
2830    
2831  =cut  =cut
2832    #: Return Type %;
2833  sub LowBBHs {  sub LowBBHs {
2834          # Get the parsameters.          # Get the parsameters.
2835          my $self = shift @_;      my ($self, $featureID, $cutoff) = @_;
         my ($featureID, $cutoff) = @_;  
2836          # Create the return hash.          # Create the return hash.
2837          my %retVal = ();          my %retVal = ();
2838          # Create a query to get the desired BBHs.          # Create a query to get the desired BBHs.
# Line 2480  Line 2848 
2848          return %retVal;          return %retVal;
2849  }  }
2850    
2851    =head3 GetGroups
2852    
2853    C<< my %groups = $sprout->GetGroups(\@groupList); >>
2854    
2855    Return a hash mapping each group to the IDs of the genomes in the group.
2856    A list of groups may be specified, in which case only those groups will be
2857    shown. Alternatively, if no parameter is supplied, all groups will be
2858    included. Genomes that are not in any group are omitted.
2859    
2860    =cut
2861    #: Return Type %@;
2862    sub GetGroups {
2863        # Get the parameters.
2864        my ($self, $groupList) = @_;
2865        # Declare the return value.
2866        my %retVal = ();
2867        # Determine whether we are getting all the groups or just some.
2868        if (defined $groupList) {
2869            # Here we have a group list. Loop through them individually,
2870            # getting a list of the relevant genomes.
2871            for my $group (@{$groupList}) {
2872                my @genomeIDs = $self->GetFlat(['Genome'], "Genome(group-name) = ?",
2873                    [$group], "Genome(id)");
2874                $retVal{$group} = \@genomeIDs;
2875            }
2876        } else {
2877            # Here we need all of the groups. In this case, we run through all
2878            # of the genome records, putting each one found into the appropriate
2879            # group. Note that we use a filter clause to insure that only genomes
2880            # in groups are included in the return set.
2881            my @genomes = $self->GetAll(['Genome'], "Genome(group-name) > ' '", [],
2882                                        ['Genome(id)', 'Genome(group-name)']);
2883            # Loop through the genomes found.
2884            for my $genome (@genomes) {
2885                # Pop this genome's ID off the current list.
2886                my @groups = @{$genome};
2887                my $genomeID = shift @groups;
2888                # Loop through the groups, adding the genome ID to each group's
2889                # list.
2890                for my $group (@groups) {
2891                    Tracer::AddToListMap(\%retVal, $group, $genomeID);
2892                }
2893            }
2894        }
2895        # Return the hash we just built.
2896        return %retVal;
2897    }
2898    
2899  =head2 Internal Utility Methods  =head2 Internal Utility Methods
2900    
2901  =head3 ParseAssignment  =head3 ParseAssignment
2902    
2903  Parse annotation text to determine whether or not it is a functional assignment. If it is,  Parse annotation text to determine whether or not it is a functional assignment. If it is,
2904  the user and function text will be returned as a 2-element list. If it isn't, an empty list  the user, function text, and assigning user will be returned as a 3-element list. If it
2905  will be returned.  isn't, an empty list will be returned.
2906    
2907    A functional assignment is always of the form
2908    
2909        I<XXXX>C<\nset >I<YYYY>C< function to\n>I<ZZZZZ>
2910    
2911    where I<XXXX> is the B<assigning user>, I<YYYY> is the B<user>, and I<ZZZZ> is the
2912    actual functional role. In most cases, the user and the assigning user will be the
2913    same, but that is not always the case.
2914    
2915  This is a static method.  This is a static method.
2916    
# Line 2505  Line 2929 
2929    
2930  =cut  =cut
2931    
2932  sub ParseAssignment {  sub _ParseAssignment {
2933          # Get the parameters.          # Get the parameters.
2934          my ($text) = @_;          my ($text) = @_;
2935          # Declare the return value.          # Declare the return value.
2936          my @retVal = ();          my @retVal = ();
2937          # Check to see if this is a functional assignment.          # Check to see if this is a functional assignment.
2938          my ($user, $type, $function) = split(/\n/, $text);          my ($user, $type, $function) = split(/\n/, $text);
2939          if ($type =~ m/^set $user function to$/i) {      if ($type =~ m/^set ([^ ]+) function to$/i) {
2940                  # Here it is, so we return the user name and function text.          # Here it is, so we return the user name (which is in $1), the functional role text,
2941                  @retVal = ($user, $function);          # and the assigning user.
2942            @retVal = ($1, $function, $user);
2943          }          }
2944          # Return the result list.          # Return the result list.
2945          return @retVal;          return @retVal;
2946  }  }
2947    
2948    =head3 FriendlyTimestamp
2949    
2950    Convert a time number to a user-friendly time stamp for display.
2951    
2952    This is a static method.
2953    
2954    =over 4
2955    
2956    =item timeValue
2957    
2958    Numeric time value.
2959    
2960    =item RETURN
2961    
2962    Returns a string containing the same time in user-readable format.
2963    
2964    =back
2965    
2966    =cut
2967    
2968    sub FriendlyTimestamp {
2969        my ($timeValue) = @_;
2970        my $retVal = strftime("%a %b %e %H:%M:%S %Y", localtime($timeValue));
2971        return $retVal;
2972    }
2973    
2974    =head3 AddProperty
2975    
2976    C<< my  = $sprout->AddProperty($featureID, $key, $value, $url); >>
2977    
2978    Add a new attribute value (Property) to a feature. In the SEED system, attributes can
2979    be added to almost any object. In Sprout, they can only be added to features. In
2980    Sprout, attributes are implemented using I<properties>. A property represents a key/value
2981    pair. If the particular key/value pair coming in is not already in the database, a new
2982    B<Property> record is created to hold it.
2983    
2984    =over 4
2985    
2986    =item peg
2987    
2988    ID of the feature to which the attribute is to be replied.
2989    
2990    =item key
2991    
2992    Name of the attribute (key).
2993    
2994    =item value
2995    
2996    Value of the attribute.
2997    
2998    =item url
2999    
3000    URL or text citation from which the property was obtained.
3001    
3002    =back
3003    
3004    =cut
3005    #: Return Type ;
3006    sub AddProperty {
3007        # Get the parameters.
3008        my ($self, $featureID, $key, $value, $url) = @_;
3009        # Declare the variable to hold the desired property ID.
3010        my $propID;
3011        # Attempt to find a property record for this key/value pair.
3012        my @properties = $self->GetFlat(['Property'],
3013                                       "Property(property-name) = ? AND Property(property-value) = ?",
3014                                       [$key, $value], 'Property(id)');
3015        if (@properties) {
3016            # Here the property is already in the database. We save its ID.
3017            $propID = $properties[0];
3018            # Here the property value does not exist. We need to generate an ID. It will be set
3019            # to a number one greater than the maximum value in the database. This call to
3020            # GetAll will stop after one record.
3021            my @maxProperty = $self->GetAll(['Property'], "ORDER BY Property(id) DESC", [], ['Property(id)'],
3022                                            1);
3023            $propID = $maxProperty[0]->[0] + 1;
3024            # Insert the new property value.
3025            $self->Insert('Property', { 'property-name' => $key, 'property-value' => $value, id => $propID });
3026        }
3027        # Now we connect the incoming feature to the property.
3028        $self->Insert('HasProperty', { 'from-link' => $featureID, 'to-link' => $propID, evidence => $url });
3029    }
3030    
3031  1;  1;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.16

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3