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

Diff of /Sprout/CustomAttributes.pm

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

revision 1.18, Tue Feb 6 16:28:40 2007 UTC revision 1.24, Fri Apr 27 22:17:39 2007 UTC
# Line 28  Line 28 
28  The actual attribute values are stored as a relationship between the attribute  The actual attribute values are stored as a relationship between the attribute
29  keys and the objects. There can be multiple values for a single key/object pair.  keys and the objects. There can be multiple values for a single key/object pair.
30    
31    =head3 Object IDs
32    
33    The object ID is normally represented as
34    
35        I<type>:I<id>
36    
37    where I<type> is the object type (C<Role>, C<Coupling>, etc.) and I<id> is
38    the actual object ID. Note that the object type must consist of only upper- and
39    lower-case letters! Thus, C<GenomeGroup> is a valid object type, but
40    C<genome_group> is not. Given that restriction, the object ID
41    
42        Family:aclame|cluster10
43    
44    would represent the FIG family C<aclame|cluster10>. For historical reasons,
45    there are three exceptions: subsystems, genomes, and features do not need
46    a type. So, for PEG 3361 of Streptomyces coelicolor A3(2), you simply code
47    
48        fig|100226.1.peg.3361
49    
50    The methods L</ParseID> and L</FormID> can be used to make this all seem
51    more consistent. Given any object ID string, L</ParseID> will convert it to an
52    object type and ID, and given any object type and ID, L</FormID> will
53    convert it to an object ID string. The attribute database is pretty
54    freewheeling about what it will allow for an ID; however, for best
55    results, the type should match an entity type from a Sprout genetics
56    database. If this rule is followed, then the database object
57    corresponding to an ID in the attribute database could be retrieved using
58    L</GetTargetObject> method.
59    
60        my $object = CustomAttributes::GetTargetObject($sprout, $idValue);
61    
62    =head3 Retrieval and Logging
63    
64  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
65  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
66  the values of the attribute C<essential> in a specified B<Feature>, you  the values of the attribute C<essential> in a specified B<Feature>, you
# Line 37  Line 70 
70    
71  where I<$fid> contains the ID of the desired feature.  where I<$fid> contains the ID of the desired feature.
72    
73  New attribute keys must be defined before they can be used. A web interface  Keys can be split into two pieces using the splitter value defined in the
74  is provided for this purpose.  constructor (the default is C<::>). The first piece of the key is called
75    the I<real key>. This portion of the key must be defined using the
76    web interface (C<Attributes.cgi>). The second portion of the key is called
77    the I<sub key>, and can take any value.
78    
79  Major attribute activity is recorded in a log (C<attributes.log>) in the  Major attribute activity is recorded in a log (C<attributes.log>) in the
80  C<$FIG_Config::var> directory. The log reports the user name, time, and  C<$FIG_Config::var> directory. The log reports the user name, time, and
81  the details of the operation. The user name will almost always be unknown,  the details of the operation. The user name will almost always be unknown,
82  except when it is specified in this object's constructor (see L</new>).  the exception being when it is specified in this object's constructor
83    (see L</new>).
84    
85  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
86    
# Line 144  Line 181 
181    
182  =item attributeName  =item attributeName
183    
184  Name of the attribute. It must be a valid ERDB field name, consisting entirely of  Name of the attribute (the real key). If it does not exist already, it will be created.
 letters, digits, and hyphens, with a letter at the beginning. If it does not  
 exist already, it will be created.  
185    
186  =item type  =item type
187    
# Line 173  Line 208 
208      # Get the data type hash.      # Get the data type hash.
209      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
210      # Validate the initial input values.      # Validate the initial input values.
211      if (! ERDB::ValidateFieldName($attributeName)) {      if ($attributeName =~ /$self->{splitter}/) {
212          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
213      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes || length($notes) < 25) {
214          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
# Line 208  Line 243 
243      }      }
244  }  }
245    
 =head3 LoadAttributeKey  
   
 C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>  
   
 Load the specified attribute from the specified file. The file should be a  
 tab-delimited file with internal tab and new-line characters escaped. This is  
 the typical TBL-style file used by most FIG applications. One of the columns  
 in the input file must contain the appropriate object id value and the other the  
 corresponding attribute value.  
   
 =over 4  
   
 =item keyName  
   
 Key of the attribute to load.  
   
 =item fh  
   
 Open file handle for the input file.  
   
 =item idCol  
   
 Index (0-based) of the column containing the ID field. The ID field should  
 contain the ID of an instance of the named entity.  
   
 =item dataCol  
   
 Index (0-based) of the column containing the data value field.  
   
 =item options  
   
 Hash specifying the options for this load.  
   
 =item RETURN  
   
 Returns a statistics object for the load process.  
   
 =back  
   
 The available options are as follows.  
   
 =over 4  
   
 =item erase  
   
 If TRUE, the key's values will all be erased before loading. (Doing so  
 makes for a faster load.)  
   
 =back  
   
 =cut  
   
 sub LoadAttributeKey {  
     # Get the parameters.  
     my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;  
     # Create the return variable.  
     my $retVal = Stats->new("lineIn", "shortLine");  
     # Compute the minimum number of fields required in each input line. The user specifies two  
     # columns, and we need to make sure both columns are in every record.  
     my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;  
     # Insure the attribute key exists.  
     my $found = $self->GetEntity('AttributeKey', $keyName);  
     if (! defined $found) {  
         Confess("Attribute key \"$keyName\" not found in database.");  
     } else {  
         # Erase the key's current values.  
         $self->EraseAttribute($keyName);  
         # Save a list of the object IDs we need to add.  
         my %objectIDs = ();  
         # Loop through the input file.  
         while (! eof $fh) {  
             # Get the next line of the file.  
             my @fields = Tracer::GetLine($fh);  
             $retVal->Add(lineIn => 1);  
             # Now we need to validate the line.  
             if (scalar(@fields) < $minCols) {  
                 $retVal->Add(shortLine => 1);  
             } else {  
                 # It's valid, so get the ID and value.  
                 my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);  
                 # Denote we're using this input line.  
                 $retVal->Add(lineUsed => 1);  
                 # Now we insert the attribute.  
                 $self->InsertObject('HasValueFor', { from => $keyName, to => $id,  
                                                      value => $value });  
                 $retVal->Add(newValue => 1);  
             }  
         }  
         # Log this operation.  
         $self->LogOperation("Load Key", $keyName, $retVal->Display());  
     }  
     # Return the statistics.  
     return $retVal;  
 }  
   
246    
247  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
248    
# Line 429  Line 369 
369                             $cgi->td($cgi->checkbox_group(-name=>'groups',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
370                                      -values=> \@groups))                                      -values=> \@groups))
371                            );                            );
372      # If the user wants to upload new values for the field, then we have      # Now the four buttons: STORE, SHOW, ERASE, and DELETE.
     # an upload file name and column indicators.  
     push @retVal, $cgi->Tr($cgi->th("Upload Values"),  
                            $cgi->td($cgi->filefield(-name => 'newValueFile',  
                                                     -size => 20) .  
                                     " Key&nbsp;" .  
                                     $cgi->textfield(-name => 'keyCol',  
                                                     -size => 3,  
                                                     -default => 0) .  
                                     " Value&nbsp;" .  
                                     $cgi->textfield(-name => 'valueCol',  
                                                     -size => 3,  
                                                     -default => 1)  
                                    ),  
                           );  
     # Now the three buttons: STORE, SHOW, and DELETE.  
373      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
374                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'}, join(" ",
375                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE'),
376                                      $cgi->submit(-name => 'Store',  -value => 'STORE') . " " .                                      $cgi->submit(-name => 'Store',  -value => 'STORE'),
377                                        $cgi->submit(-name => 'Erase',  -value => 'ERASE'),
378                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')
379                                     )                                     ))
380                            );                            );
381      # Close the table and the form.      # Close the table and the form.
382      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
# Line 461  Line 387 
387  =head3 LoadAttributesFrom  =head3 LoadAttributesFrom
388    
389  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
390    s
391  Load attributes from the specified tab-delimited file. Each line of the file must  Load attributes from the specified tab-delimited file. Each line of the file must
392  contain an object ID in the first column, an attribute key name in the second  contain an object ID in the first column, an attribute key name in the second
393  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values will
394  be assembled into a single value using the splitter code.  be assembled into a single value using the splitter code. In addition, the key names may
395    contain a splitter. If this is the case, the portion of the key after the splitter is
396    treated as a subkey.
397    
398  =over 4  =over 4
399    
400  =item fileName  =item fileName
401    
402  Name of the file from which to load the attributes.  Name of the file from which to load the attributes, or an open handle for the file.
403    (This last enables the method to be used in conjunction with the CGI form upload
404    control.)
405    
406  =item options  =item options
407    
# Line 492  Line 422 
422  If TRUE, then the attributes will be appended to existing data; otherwise, the  If TRUE, then the attributes will be appended to existing data; otherwise, the
423  first time a key name is encountered, it will be erased.  first time a key name is encountered, it will be erased.
424    
425    =item archive
426    
427    If specified, the name of a file into which the incoming data file should be saved.
428    
429    =item objectType
430    
431    If specified, the specified object type will be prefixed to each object ID.
432    
433  =back  =back
434    
435  =cut  =cut
# Line 505  Line 443 
443      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
444      # Create a hash of key names found.      # Create a hash of key names found.
445      my %keyHash = ();      my %keyHash = ();
446      # Open the file for input.      # Open the file for input. Note we must anticipate the possibility of an
447      my $fh = Open(undef, "<$fileName");      # open filehandle being passed in.
448        my $fh;
449        if (ref $fileName) {
450            Trace("Using file opened by caller.") if T(3);
451            $fh = $fileName;
452        } else {
453            Trace("Attributes will be loaded from $fileName.") if T(3);
454            $fh = Open(undef, "<$fileName");
455        }
456        # Now check to see if we need to archive.
457        my $ah;
458        if ($options{archive}) {
459            $ah = Open(undef, ">$options{archive}");
460            Trace("Load file will be archived to $options{archive}.") if T(3);
461        }
462        # Finally, open a database transaction.
463        $self->BeginTran();
464        # Insure we recover from errors. If an error occurs, we will delete the archive file and
465        # roll back the updates.
466        eval {
467      # Loop through the file.      # Loop through the file.
468      while (! eof $fh) {      while (! eof $fh) {
469                # Read the current line.
470          my ($id, $key, @values) = Tracer::GetLine($fh);          my ($id, $key, @values) = Tracer::GetLine($fh);
471          $retVal->Add(linesIn => 1);          $retVal->Add(linesIn => 1);
472                # Check to see if we need to fix up the object ID.
473                if ($options{objectType}) {
474                    $id = "$options{objectType}:$id";
475                }
476                # Archive the line (if necessary).
477                if (defined $ah) {
478                    Tracer::PutLine($ah, [$id, $key, @values]);
479                }
480          # Do some validation.          # Do some validation.
481          if (! defined($id)) {              if (! $id) {
482              # We ignore blank lines.              # We ignore blank lines.
483              $retVal->Add(blankLines => 1);              $retVal->Add(blankLines => 1);
484                } elsif (substr($id, 0, 1) eq '#') {
485                    # A line beginning with a pound sign is a comment.
486                    $retVal->Add(comments => 1);
487          } elsif (! defined($key)) {          } elsif (! defined($key)) {
488              # An ID without a key is a serious error.              # An ID without a key is a serious error.
489              my $lines = $retVal->Ask('linesIn');              my $lines = $retVal->Ask('linesIn');
490              Confess("Line $lines in $fileName has no attribute key.");              Confess("Line $lines in $fileName has no attribute key.");
491                } elsif (! @values) {
492                    # A line with no values is not allowed.
493                    my $lines = $retVal->Ask('linesIn');
494                    Trace("Line $lines for key $key has no attribute values.") if T(1);
495                    $retVal->Add(skipped => 1);
496          } else {          } else {
497                    # The key contains a real part and an optional sub-part. We need the real part.
498                    my ($realKey, $subKey) = $self->SplitKey($key);
499              # Now we need to check for a new key.              # Now we need to check for a new key.
500              if (! exists $keyHash{$key}) {                  if (! exists $keyHash{$realKey}) {
501                  # This is a new key. Verify that it exists.                      if (! $self->Exists('AttributeKey', $realKey)) {
                 if (! $self->Exists('AttributeKey', $key)) {  
502                      my $line = $retVal->Ask('linesIn');                      my $line = $retVal->Ask('linesIn');
503                      Confess("Attribute \"$key\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
504                  } else {                  } else {
505                      # Make sure we know this is no longer a new key.                      # Make sure we know this is no longer a new key.
506                      $keyHash{$key} = 1;                          $keyHash{$realKey} = 1;
507                      $retVal->Add(keys => 1);                      $retVal->Add(keys => 1);
508                      # If this is NOT append mode, erase the key.                      # If this is NOT append mode, erase the key.
509                      if (! $append) {                      if (! $append) {
510                          $self->EraseAttribute($key);                              $self->EraseAttribute($realKey);
511                      }                      }
512                  }                  }
513                  Trace("Key $key found.") if T(3);                      Trace("Key $realKey found.") if T(3);
514              }              }
515              # Now we know the key is valid. Add this value.                  # Everything is all set up, so add the value.
516              $self->AddAttribute($id, $key, @values);              $self->AddAttribute($id, $key, @values);
517              my $progress = $retVal->Add(values => 1);              my $progress = $retVal->Add(values => 1);
518              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
519                }
520            }
521        };
522        # Check for an error.
523        if ($@) {
524            # Here we have an error. Roll back the transaction and delete the archive file.
525            my $message = $@;
526            Trace("Rolling back attribute updates due to error.") if T(1);
527            $self->RollbackTran();
528            if (defined $ah) {
529                Trace("Deleting archive file $options{archive}.") if T(1);
530                close $ah;
531                unlink $options{archive};
532            }
533            Confess("Error during attribute load: $message");
534        } else {
535            # Here the load worked. Commit the transaction and close the archive file.
536            Trace("Committing attribute upload.") if T(2);
537            $self->CommitTran();
538            if (defined $ah) {
539                Trace("Closing archive file $options{archive}.") if T(2);
540                close $ah;
541          }          }
542      }      }
543      # Return the result.      # Return the result.
# Line 682  Line 678 
678      return $retVal;      return $retVal;
679  }  }
680    
681    =head3 ArchiveFileName
682    
683    C<< my $fileName = $ca->ArchiveFileName(); >>
684    
685    Compute a file name for archiving attribute input data. The file will be in the attribute log directory
686    
687    =cut
688    
689    sub ArchiveFileName {
690        # Get the parameters.
691        my ($self) = @_;
692        # Declare the return variable.
693        my $retVal;
694        # We start by turning the timestamp into something usable as a file name.
695        my $now = Tracer::Now();
696        $now =~ tr/ :\//___/;
697        # Next we get the directory name.
698        my $dir = "$FIG_Config::var/attributes";
699        if (! -e $dir) {
700            Trace("Creating attribute file directory $dir.") if T(1);
701            mkdir $dir;
702        }
703        # Put it together with the field name and the time stamp.
704        $retVal = "$dir/upload.$now";
705        # Modify the file name to insure it's unique.
706        my $seq = 0;
707        while (-e "$retVal.$seq.tbl") { $seq++ }
708        # Use the computed sequence number to get the correct file name.
709        $retVal .= ".$seq.tbl";
710        # Return the result.
711        return $retVal;
712    }
713    
714  =head3 BackupAllAttributes  =head3 BackupAllAttributes
715    
# Line 730  Line 758 
758          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
759              $valuesFound++;              $valuesFound++;
760              # Get this row's data.              # Get this row's data.
761              my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',
762                                                                 'HasValueFor(from-link)',
763                                                                 'HasValueFor(subkey)',
764                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
765                # Check for a subkey.
766                if ($subKey ne '') {
767                    $key = "$key$self->{splitter}$subKey";
768                }
769              # Write it to the file.              # Write it to the file.
770              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, [$id, $key, $value]);
771          }          }
772          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
773          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
# Line 1136  Line 1170 
1170      # Loop through the assignments found.      # Loop through the assignments found.
1171      while (my $row = $query->Fetch()) {      while (my $row = $query->Fetch()) {
1172          # Get the current row's data.          # Get the current row's data.
1173          my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',          my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',
1174                                                        'HasValueFor(value)']);                                                                    'HasValueFor(from-link)',
1175                                                                      'HasValueFor(subkey)',
1176                                                                      'HasValueFor(value)'
1177                                                                    ]);
1178            # Form the key from the real key and the sub key.
1179            my $key = $self->JoinKey($realKey, $subKey);
1180          # Break the value into sections.          # Break the value into sections.
1181          my @sections = split($self->{splitter}, $valueString);          my @sections = split($self->{splitter}, $valueString);
1182          # Match each section against the incoming values. We'll assume we're          # Match each section against the incoming values. We'll assume we're
# Line 1150  Line 1189 
1189              if (substr($value, -1, 1) eq '%') {              if (substr($value, -1, 1) eq '%') {
1190                  Trace("Generic match used.") if T(4);                  Trace("Generic match used.") if T(4);
1191                  # Here we have a generic match.                  # Here we have a generic match.
1192                  my $matchLen = length($values[$i] - 1);                  my $matchLen = length($values[$i]) - 1;
1193                  $matching = substr($sections[$i], 0, $matchLen) eq                  $matching = substr($sections[$i], 0, $matchLen) eq
1194                              substr($values[$i], 0, $matchLen);                              substr($values[$i], 0, $matchLen);
1195              } elsif ($value =~ m#^/(.+)/[a-z]*$#) {              } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
# Line 1184  Line 1223 
1223  The idea is that these methods represent attribute manipulation allowed by all users, while  The idea is that these methods represent attribute manipulation allowed by all users, while
1224  the others are only for privileged users with access to the attribute server.  the others are only for privileged users with access to the attribute server.
1225    
1226  In the previous implementation, an attribute had a value and a URL. In the new implementation,  In the previous implementation, an attribute had a value and a URL. In this implementation,
1227  there is only a value. In this implementation, each attribute has only a value. These  each attribute has only a value. These methods will treat the value as a list with the individual
1228  methods will treat the value as a list with the individual elements separated by the  elements separated by the value of the splitter parameter on the constructor (L</new>). The default
1229  value of the splitter parameter on the constructor (L</new>). The default is double  is double colons C<::>.
 colons C<::>.  
1230    
1231  So, for example, an old-style keyword with a value of C<essential> and a URL of  So, for example, an old-style keyword with a value of C<essential> and a URL of
1232  C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default  C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
# Line 1240  Line 1278 
1278  which has no wildcard in the key or the object ID, may return multiple tuples.  which has no wildcard in the key or the object ID, may return multiple tuples.
1279    
1280  Value matching in this system works very poorly, because of the way multiple values are  Value matching in this system works very poorly, because of the way multiple values are
1281  stored. For the object ID and key name, we create queries that filter for the desired  stored. For the object ID, key name, and first value, we create queries that filter for the
1282  results. For the values, we do a comparison after the attributes are retrieved from the  desired results. On any filtering by value, we must do a comparison after the attributes are
1283  database. As a result, queries in which filter only on value end up reading the entire  retrieved from the database, since the database has no notion of the multiple values, which
1284  attribute table to find the desired results.  are stored in a single string. As a result, queries in which filter only on value end up
1285    reading a lot more than they need to.
1286    
1287  =over 4  =over 4
1288    
# Line 1285  Line 1324 
1324  sub GetAttributes {  sub GetAttributes {
1325      # Get the parameters.      # Get the parameters.
1326      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1327      # We will create one big honking query. The following hash will build the filter      # This hash will map "HasValueFor" fields to patterns. We use it to build the
1328      # clause and a parameter list.      # SQL statement.
1329      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);      my %data;
1330        # Before we do anything else, we must parse the key. The key is treated by the
1331        # user as a single field, but to us it's actually a real key and a subkey.
1332        # If the key has no splitter and is exact, the real key is the original key
1333        # and the subkey is an empty string. If the key has a splitter, it is
1334        # split into two pieces and each piece is processed separately. If the key has
1335        # no splitter and is generic, the real key is the incoming key and the subkey
1336        # is allowed to be wild. Of course, this only matters if an actual key has
1337        # been specified.
1338        if (defined $key) {
1339            if ($key =~ /$self->{splitter}/) {
1340                # Here we have a two-part key, so we split it normally.
1341                my ($realKey, $subKey) = $self->SplitKey($key);
1342                $data{'HasValueFor(from-link)'} = $realKey;
1343                $data{'HasValueFor(subkey)'} = $subKey;
1344            } elsif (substr($key, -1, 1) eq '%') {
1345                $data{'HasValueFor(from-link)'} = $key;
1346            } else {
1347                $data{'HasValueFor(from-link)'} = $key;
1348                $data{'HasValueFor(subkey)'} = '';
1349            }
1350        }
1351        # Add the object ID to the key information.
1352        $data{'HasValueFor(to-link)'} = $objectID;
1353        # The first value represents a problem, because we can search it using SQL, but not
1354        # in the normal way. If the user specifies a generic search or exact match for
1355        # every alternative value (remember, the values may be specified as a list),
1356        # then we can create SQL filtering for it. If any of the values are specified
1357        # as a regular expression, however, that's a problem, because we need to read
1358        # every value to verify a match.
1359        if (@values > 0) {
1360            # Get the first value and put its alternatives in an array.
1361            my $valueParm = $values[0];
1362            my @valueList;
1363            if (ref $valueParm eq 'ARRAY') {
1364                @valueList = @{$valueParm};
1365            } else {
1366                @valueList = ($valueParm);
1367            }
1368            # Okay, now we have all the possible criteria for the first value in the list
1369            # @valueList. We'll copy the values to a new array in which they have been
1370            # converted to generic requests. If we find a regular-expression match
1371            # anywhere in the list, we toss the whole thing.
1372            my @valuePatterns = ();
1373            my $okValues = 1;
1374            for my $valuePattern (@valueList) {
1375                # Check the pattern type.
1376                if (substr($valuePattern, 0, 1) eq '/') {
1377                    # Regular expressions invalidate the entire process.
1378                    $okValues = 0;
1379                } elsif (substr($valuePattern, -1, 1) eq '%') {
1380                    # A Generic pattern is passed in unmodified.
1381                    push @valuePatterns, $valuePattern;
1382                } else {
1383                    # An exact match is converted to generic.
1384                    push @valuePatterns, "$valuePattern%";
1385                }
1386            }
1387            # If everything works, add the value data to the filtering hash.
1388            if ($okValues) {
1389                $data{'HasValueFor(value)'} = \@valuePatterns;
1390            }
1391        }
1392        # Create some lists to contain the filter fragments and parameter values.
1393      my @filter = ();      my @filter = ();
1394      my @parms = ();      my @parms = ();
1395      # This next loop goes through the different fields that can be specified in the      # This next loop goes through the different fields that can be specified in the
1396      # parameter list and generates filters for each.      # parameter list and generates filters for each. The %data hash that we built above
1397        # contains all the necessary information to do this.
1398      for my $field (keys %data) {      for my $field (keys %data) {
1399          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1400          # elements accumulated to create the final result.          # elements accumulated to create the final result.
# Line 1319  Line 1422 
1422                          push @fieldFilter, "$field = ?";                          push @fieldFilter, "$field = ?";
1423                          push @parms, $pattern;                          push @parms, $pattern;
1424                      } else {                      } else {
1425                          # Here we have a generate request, so we will use the LIKE operator to                          # Here we have a generic request, so we will use the LIKE operator to
1426                          # filter the field to this value pattern.                          # filter the field to this value pattern.
1427                          push @fieldFilter, "$field LIKE ?";                          push @fieldFilter, "$field LIKE ?";
1428                          # We must convert the pattern value to an SQL match pattern. First                          # We must convert the pattern value to an SQL match pattern. First
# Line 1390  Line 1493 
1493          # Okay, now we have some reason to believe we can do this. Form the values          # Okay, now we have some reason to believe we can do this. Form the values
1494          # into a scalar.          # into a scalar.
1495          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1496            # Split up the key.
1497            my ($realKey, $subKey) = $self->SplitKey($key);
1498          # Connect the object to the key.          # Connect the object to the key.
1499          $self->InsertObject('HasValueFor', { 'from-link' => $key,          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,
1500                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1501                                                 'subkey'    => $subKey,
1502                                               'value'     => $valueString,                                               'value'     => $valueString,
1503                                         });                                         });
1504      }      }
# Line 1433  Line 1539 
1539          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1540      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1541          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1542      } elsif (scalar(@values) == 0) {      } else {
1543            # Split the key into the real key and the subkey.
1544            my ($realKey, $subKey) = $self->SplitKey($key);
1545            if ($subKey eq '' && scalar(@values) == 0) {
1546          # Here we erase the entire key for this object.          # Here we erase the entire key for this object.
1547          $self->DeleteRow('HasValueFor', $key, $objectID);          $self->DeleteRow('HasValueFor', $key, $objectID);
1548      } else {      } else {
1549          # Here we erase the matching values.          # Here we erase the matching values.
1550          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1551          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });              $self->DeleteRow('HasValueFor', $realKey, $objectID,
1552                                 { subkey => $subKey, value => $valueString });
1553            }
1554      }      }
1555      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1556      return 1;      return 1;
# Line 1568  Line 1679 
1679    
1680  =item key  =item key
1681    
1682  Key to erase.  Key to erase. This must be a real key; that is, it cannot have a subkey
1683    component.
1684    
1685  =back  =back
1686    
# Line 1615  Line 1727 
1727      return sort @groups;      return sort @groups;
1728  }  }
1729    
1730    =head3 QueryAttributes
1731    
1732    C<< my @attributeData = $ca->QueryAttributes($filter, $filterParms); >>
1733    
1734    Return the attribute data based on an SQL filter clause. In the filter clause,
1735    the name C<$object> should be used for the object ID, C<$key> should be used for
1736    the key name, C<$subkey> for the subkey value, and C<$value> for the value field.
1737    
1738    =over 4
1739    
1740    =item filter
1741    
1742    Filter clause in the standard ERDB format, except that the field names are C<$object> for
1743    the object ID field, C<$key> for the key name field, C<$subkey> for the subkey field,
1744    and C<$value> for the value field. This abstraction enables us to hide the details of
1745    the database construction from the user.
1746    
1747    =item filterParms
1748    
1749    Parameters for the filter clause.
1750    
1751    =item RETURN
1752    
1753    Returns a list of tuples. Each tuple consists of an object ID, a key (with optional subkey), and
1754    one or more attribute values.
1755    
1756    =back
1757    
1758    =cut
1759    
1760    # This hash is used to drive the substitution process.
1761    my %AttributeParms = (object => 'HasValueFor(to-link)',
1762                          key    => 'HasValueFor(from-link)',
1763                          subkey => 'HasValueFor(subkey)',
1764                          value  => 'HasValueFor(value)');
1765    
1766    sub QueryAttributes {
1767        # Get the parameters.
1768        my ($self, $filter, $filterParms) = @_;
1769        # Declare the return variable.
1770        my @retVal = ();
1771        # Make sue we have filter parameters.
1772        my $realParms = (defined($filterParms) ? $filterParms : []);
1773        # Create the query by converting the filter.
1774        my $realFilter = $filter;
1775        for my $name (keys %AttributeParms) {
1776            $realFilter =~ s/\$$name/$AttributeParms{$name}/g;
1777        }
1778        my $query = $self->Get(['HasValueFor'], $realFilter, $realParms);
1779        # Loop through the results, forming the output attribute tuples.
1780        while (my $result = $query->Fetch()) {
1781            # Get the four values from this query result row.
1782            my ($objectID, $key, $subkey, $value) = $result->Values([$AttributeParms{object},
1783                                                                    $AttributeParms{key},
1784                                                                    $AttributeParms{subkey},
1785                                                                    $AttributeParms{value}]);
1786            # Combine the key and the subkey.
1787            my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);
1788            # Split the value.
1789            my @values = split $self->{splitter}, $value;
1790            # Output the result.
1791            push @retVal, [$objectID, $realKey, @values];
1792        }
1793        # Return the result.
1794        return @retVal;
1795    }
1796    
1797    =head2 Key and ID Manipulation Methods
1798    
1799    =head3 ParseID
1800    
1801    C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
1802    
1803    Determine the type and object ID corresponding to an ID value from the attribute database.
1804    Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
1805    however, Genomes, Features, and Subsystems are not stored with a type name, so we need to
1806    deduce the type from the ID value structure.
1807    
1808    The theory here is that you can plug the ID and type directly into a Sprout database method, as
1809    follows
1810    
1811        my ($type, $id) = CustomAttributes::ParseID($attrList[$num]->[0]);
1812        my $target = $sprout->GetEntity($type, $id);
1813    
1814    =over 4
1815    
1816    =item idValue
1817    
1818    ID value taken from the attribute database.
1819    
1820    =item RETURN
1821    
1822    Returns a two-element list. The first element is the type of object indicated by the ID value,
1823    and the second element is the actual object ID.
1824    
1825    =back
1826    
1827    =cut
1828    
1829    sub ParseID {
1830        # Get the parameters.
1831        my ($idValue) = @_;
1832        # Declare the return variables.
1833        my ($type, $id);
1834        # Parse the incoming ID. We first check for the presence of an entity name. Entity names
1835        # can only contain letters, which helps to insure typed object IDs don't collide with
1836        # subsystem names (which are untyped).
1837        if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1838            # Here we have a typed ID.
1839            ($type, $id) = ($1, $2);
1840        } elsif ($idValue =~ /fig\|/) {
1841            # Here we have a feature ID.
1842            ($type, $id) = (Feature => $idValue);
1843        } elsif ($idValue =~ /\d+\.\d+/) {
1844            # Here we have a genome ID.
1845            ($type, $id) = (Genome => $idValue);
1846        } else {
1847            # The default is a subsystem ID.
1848            ($type, $id) = (Subsystem => $idValue);
1849        }
1850        # Return the results.
1851        return ($type, $id);
1852    }
1853    
1854    =head3 FormID
1855    
1856    C<< my $idValue = CustomAttributes::FormID($type, $id); >>
1857    
1858    Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1859    genomes, and features are stored in the database without type information, but all other object IDs
1860    must be prefixed with the object type.
1861    
1862    =over 4
1863    
1864    =item type
1865    
1866    Relevant object type.
1867    
1868    =item id
1869    
1870    ID of the object in question.
1871    
1872    =item RETURN
1873    
1874    Returns a string that will be recognized as an object ID in the attribute database.
1875    
1876    =back
1877    
1878    =cut
1879    
1880    sub FormID {
1881        # Get the parameters.
1882        my ($type, $id) = @_;
1883        # Declare the return variable.
1884        my $retVal;
1885        # Compute the ID string from the type.
1886        if (grep { $type eq $_ } qw(Feature Genome Subsystem)) {
1887            $retVal = $id;
1888        } else {
1889            $retVal = "$type:$id";
1890        }
1891        # Return the result.
1892        return $retVal;
1893    }
1894    
1895    =head3 GetTargetObject
1896    
1897    C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>
1898    
1899    Return the database object corresponding to the specified attribute object ID. The
1900    object type associated with the ID value must correspond to an entity name in the
1901    specified database.
1902    
1903    =over 4
1904    
1905    =item erdb
1906    
1907    B<ERDB> object for accessing the target database.
1908    
1909    =item idValue
1910    
1911    ID value retrieved from the attribute database.
1912    
1913    =item RETURN
1914    
1915    Returns a B<ERDBObject> for the attribute value's target object.
1916    
1917    =back
1918    
1919    =cut
1920    
1921    sub GetTargetObject {
1922        # Get the parameters.
1923        my ($erdb, $idValue) = @_;
1924        # Declare the return variable.
1925        my $retVal;
1926        # Get the type and ID for the target object.
1927        my ($type, $id) = ParseID($idValue);
1928        # Plug them into the GetEntity method.
1929        $retVal = $erdb->GetEntity($type, $id);
1930        # Return the resulting object.
1931        return $retVal;
1932    }
1933    
1934    =head3 SplitKey
1935    
1936    C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>
1937    
1938    Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1939    The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
1940    then the sub key is presumed to be an empty string.
1941    
1942    =over 4
1943    
1944    =item key
1945    
1946    Incoming key to be split.
1947    
1948    =item RETURN
1949    
1950    Returns a two-element list, the first element of which is the real key and the second element of
1951    which is the sub key.
1952    
1953    =back
1954    
1955    =cut
1956    
1957    sub SplitKey {
1958        # Get the parameters.
1959        my ($self, $key) = @_;
1960        # Do the split.
1961        my ($realKey, $subKey) = split($self->{splitter}, $key, 2);
1962        # Insure the subkey has a value.
1963        if (! defined $subKey) {
1964            $subKey = '';
1965        }
1966        # Return the results.
1967        return ($realKey, $subKey);
1968    }
1969    
1970    =head3 JoinKey
1971    
1972    C<< my $key = $ca->JoinKey($realKey, $subKey); >>
1973    
1974    Join a real key and a subkey together to make an external key. The external key is the attribute key
1975    used by the caller. The real key and the subkey are how the keys are represented in the database. The
1976    real key is the key to the B<AttributeKey> entity. The subkey is an attribute of the B<HasValueFor>
1977    relationship.
1978    
1979    =over 4
1980    
1981    =item realKey
1982    
1983    The real attribute key.
1984    
1985    =item subKey
1986    
1987    The subordinate portion of the attribute key.
1988    
1989    =item RETURN
1990    
1991    Returns a single string representing both keys.
1992    
1993    =back
1994    
1995    =cut
1996    
1997    sub JoinKey {
1998        # Get the parameters.
1999        my ($self, $realKey, $subKey) = @_;
2000        # Declare the return variable.
2001        my $retVal;
2002        # Check for a subkey.
2003        if ($subKey eq '') {
2004            # No subkey, so the real key is the key.
2005            $retVal = $realKey;
2006        } else {
2007            # Subkey found, so the two pieces must be joined by a splitter.
2008            $retVal = "$realKey$self->{splitter}$subKey";
2009        }
2010        # Return the result.
2011        return $retVal;
2012    }
2013    
2014  1;  1;

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.24

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3