[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.21, Sun Feb 18 22:13:53 2007 UTC revision 1.30, Fri Oct 5 01:40:58 2007 UTC
# Line 9  Line 9 
9      use Tracer;      use Tracer;
10      use ERDBLoad;      use ERDBLoad;
11      use Stats;      use Stats;
12        use Time::HiRes qw(time);
13    
14  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
15    
# Line 344  Line 345 
345                                      -labels => \%labelMap,                                      -labels => \%labelMap,
346                                      -default => 'string');                                      -default => 'string');
347      # Allow the user to specify a new field name. This is required if the      # Allow the user to specify a new field name. This is required if the
348      # user has selected the "(new)" marker. We put a little scriptlet in here that      # user has selected the "(new)" marker.
     # selects the (new) marker when the user enters the field.  
     push @retVal, "<script language=\"javaScript\">";  
349      my $fieldField = "document.$name.fieldName";      my $fieldField = "document.$name.fieldName";
350      my $newName = "\"" . NewName() . "\"";      my $newName = "\"" . NewName() . "\"";
351      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("New Field Name"),
# Line 387  Line 386 
386  =head3 LoadAttributesFrom  =head3 LoadAttributesFrom
387    
388  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
389    s
390  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
391  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
392  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values will
# Line 430  Line 429 
429    
430  If specified, the specified object type will be prefixed to each object ID.  If specified, the specified object type will be prefixed to each object ID.
431    
432    =item resume
433    
434    If specified, key-value pairs already in the database will not be reinserted.
435    
436  =back  =back
437    
438  =cut  =cut
# Line 439  Line 442 
442      my ($self, $fileName, %options) = @_;      my ($self, $fileName, %options) = @_;
443      # Declare the return variable.      # Declare the return variable.
444      my $retVal = Stats->new('keys', 'values');      my $retVal = Stats->new('keys', 'values');
445        # Initialize the timers.
446        my ($insertTime, $eraseTime, $archiveTime, $checkTime) = (0, 0, 0, 0);
447      # Check for append mode.      # Check for append mode.
448      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
449        # Check for resume mode.
450        my $resume = ($options{resume} ? 1 : 0);
451      # Create a hash of key names found.      # Create a hash of key names found.
452      my %keyHash = ();      my %keyHash = ();
453      # Open the file for input. Note we must anticipate the possibility of an      # Open the file for input. Note we must anticipate the possibility of an
# Line 459  Line 466 
466          $ah = Open(undef, ">$options{archive}");          $ah = Open(undef, ">$options{archive}");
467          Trace("Load file will be archived to $options{archive}.") if T(3);          Trace("Load file will be archived to $options{archive}.") if T(3);
468      }      }
469      # Finally, open a database transaction.      # Insure we recover from errors.
     $self->BeginTran();  
     # Insure we recover from errors. If an error occurs, we will delete the archive file and  
     # roll back the updates.  
470      eval {      eval {
471          # Loop through the file.          # Loop through the file.
472          while (! eof $fh) {          while (! eof $fh) {
# Line 475  Line 479 
479              }              }
480              # Archive the line (if necessary).              # Archive the line (if necessary).
481              if (defined $ah) {              if (defined $ah) {
482                    my $startTime = time();
483                  Tracer::PutLine($ah, [$id, $key, @values]);                  Tracer::PutLine($ah, [$id, $key, @values]);
484                    $archiveTime += time() - $startTime;
485              }              }
486              # Do some validation.              # Do some validation.
487              if (! $id) {              if (! $id) {
# Line 488  Line 494 
494                  # An ID without a key is a serious error.                  # An ID without a key is a serious error.
495                  my $lines = $retVal->Ask('linesIn');                  my $lines = $retVal->Ask('linesIn');
496                  Confess("Line $lines in $fileName has no attribute key.");                  Confess("Line $lines in $fileName has no attribute key.");
497                } elsif (! @values) {
498                    # A line with no values is not allowed.
499                    my $lines = $retVal->Ask('linesIn');
500                    Trace("Line $lines for key $key has no attribute values.") if T(1);
501                    $retVal->Add(skipped => 1);
502              } else {              } else {
503                  # The key contains a real part and an optional sub-part. We need the real part.                  # The key contains a real part and an optional sub-part. We need the real part.
504                  my ($realKey, $subKey) = $self->SplitKey($key);                  my ($realKey, $subKey) = $self->SplitKey($key);
# Line 502  Line 513 
513                          $retVal->Add(keys => 1);                          $retVal->Add(keys => 1);
514                          # If this is NOT append mode, erase the key.                          # If this is NOT append mode, erase the key.
515                          if (! $append) {                          if (! $append) {
516                                my $startTime = time();
517                              $self->EraseAttribute($realKey);                              $self->EraseAttribute($realKey);
518                                $eraseTime += time() - $startTime;
519                                Trace("Attribute $realKey erased.") if T(3);
520                          }                          }
521                      }                      }
522                      Trace("Key $realKey found.") if T(3);                      Trace("Key $realKey found.") if T(3);
523                  }                  }
524                    # If we're in resume mode, check to see if this insert is redundant.
525                    my $ok = 1;
526                    if ($resume) {
527                        my $startTime = time();
528                        my $count = $self->GetAttributes($id, $key, @values);
529                        $ok = ! $count;
530                        $checkTime += time() - $startTime;
531                    }
532                    if ($ok) {
533                  # Everything is all set up, so add the value.                  # Everything is all set up, so add the value.
534                        my $startTime = time();
535                  $self->AddAttribute($id, $key, @values);                  $self->AddAttribute($id, $key, @values);
536                        $insertTime += time() - $startTime;
537                        # Turn off resume mode.
538                        $resume = 0;
539                    } else {
540                        # Here we skipped because of resume mode.
541                        $retVal->Add(resumeSkip => 1);
542                    }
543    
544                  my $progress = $retVal->Add(values => 1);                  my $progress = $retVal->Add(values => 1);
545                  Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);                  Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
546              }              }
547          }          }
548            $retVal->Add(eraseTime   => $eraseTime);
549            $retVal->Add(insertTime  => $insertTime);
550            $retVal->Add(archiveTime => $archiveTime);
551            $retVal->Add(checkTime   => $checkTime);
552      };      };
553      # Check for an error.      # Check for an error.
554      if ($@) {      if ($@) {
555          # Here we have an error. Roll back the transaction and delete the archive file.          # Here we have an error. Display the error message.
556          my $message = $@;          my $message = $@;
557          Trace("Rolling back attribute updates due to error.") if T(1);          Trace("Error during attribute load: $message") if T(0);
558          $self->RollbackTran();          $retVal->AddMessage($message);
         if (defined $ah) {  
             Trace("Deleting archive file $options{archive}.") if T(1);  
             close $ah;  
             unlink $options{archive};  
559          }          }
560          Confess("Error during attribute load: $message");      # Close the archive file, if any.
     } else {  
         # Here the load worked. Commit the transaction and close the archive file.  
         Trace("Committing attribute upload.") if T(2);  
         $self->CommitTran();  
561          if (defined $ah) {          if (defined $ah) {
562              Trace("Closing archive file $options{archive}.") if T(2);              Trace("Closing archive file $options{archive}.") if T(2);
563              close $ah;              close $ah;
564          }          }
     }  
565      # Return the result.      # Return the result.
566      return $retVal;      return $retVal;
567  }  }
# Line 1439  Line 1466 
1466      # Now @filter contains one or more filter strings and @parms contains the parameter      # Now @filter contains one or more filter strings and @parms contains the parameter
1467      # values to bind to them.      # values to bind to them.
1468      my $actualFilter = join(" AND ", @filter);      my $actualFilter = join(" AND ", @filter);
1469        # Insure we have at least one filter.
1470        if (! $actualFilter) {
1471            Confess("No filter specified in GetAttributes query.");
1472        }
1473      # Now we're ready to make our query.      # Now we're ready to make our query.
1474      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1475      # Format the results.      # Format the results.
# Line 1722  Line 1753 
1753      return sort @groups;      return sort @groups;
1754  }  }
1755    
1756    =head3 QueryAttributes
1757    
1758    C<< my @attributeData = $ca->QueryAttributes($filter, $filterParms); >>
1759    
1760    Return the attribute data based on an SQL filter clause. In the filter clause,
1761    the name C<$object> should be used for the object ID, C<$key> should be used for
1762    the key name, C<$subkey> for the subkey value, and C<$value> for the value field.
1763    
1764    =over 4
1765    
1766    =item filter
1767    
1768    Filter clause in the standard ERDB format, except that the field names are C<$object> for
1769    the object ID field, C<$key> for the key name field, C<$subkey> for the subkey field,
1770    and C<$value> for the value field. This abstraction enables us to hide the details of
1771    the database construction from the user.
1772    
1773    =item filterParms
1774    
1775    Parameters for the filter clause.
1776    
1777    =item RETURN
1778    
1779    Returns a list of tuples. Each tuple consists of an object ID, a key (with optional subkey), and
1780    one or more attribute values.
1781    
1782    =back
1783    
1784    =cut
1785    
1786    # This hash is used to drive the substitution process.
1787    my %AttributeParms = (object => 'HasValueFor(to-link)',
1788                          key    => 'HasValueFor(from-link)',
1789                          subkey => 'HasValueFor(subkey)',
1790                          value  => 'HasValueFor(value)');
1791    
1792    sub QueryAttributes {
1793        # Get the parameters.
1794        my ($self, $filter, $filterParms) = @_;
1795        # Declare the return variable.
1796        my @retVal = ();
1797        # Make sue we have filter parameters.
1798        my $realParms = (defined($filterParms) ? $filterParms : []);
1799        # Create the query by converting the filter.
1800        my $realFilter = $filter;
1801        for my $name (keys %AttributeParms) {
1802            $realFilter =~ s/\$$name/$AttributeParms{$name}/g;
1803        }
1804        my $query = $self->Get(['HasValueFor'], $realFilter, $realParms);
1805        # Loop through the results, forming the output attribute tuples.
1806        while (my $result = $query->Fetch()) {
1807            # Get the four values from this query result row.
1808            my ($objectID, $key, $subkey, $value) = $result->Values([$AttributeParms{object},
1809                                                                    $AttributeParms{key},
1810                                                                    $AttributeParms{subkey},
1811                                                                    $AttributeParms{value}]);
1812            # Combine the key and the subkey.
1813            my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);
1814            # Split the value.
1815            my @values = split $self->{splitter}, $value;
1816            # Output the result.
1817            push @retVal, [$objectID, $realKey, @values];
1818        }
1819        # Return the result.
1820        return @retVal;
1821    }
1822    
1823  =head2 Key and ID Manipulation Methods  =head2 Key and ID Manipulation Methods
1824    
1825  =head3 ParseID  =head3 ParseID
# Line 1765  Line 1863 
1863      if ($idValue =~ /^([A-Za-z]+):(.+)/) {      if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1864          # Here we have a typed ID.          # Here we have a typed ID.
1865          ($type, $id) = ($1, $2);          ($type, $id) = ($1, $2);
1866            # Fix the case sensitivity on PDB IDs.
1867            if ($type eq 'PDB') { $id = lc $id; }
1868      } elsif ($idValue =~ /fig\|/) {      } elsif ($idValue =~ /fig\|/) {
1869          # Here we have a feature ID.          # Here we have a feature ID.
1870          ($type, $id) = (Feature => $idValue);          ($type, $id) = (Feature => $idValue);
# Line 1840  Line 1940 
1940    
1941  =item RETURN  =item RETURN
1942    
1943  Returns a B<DBObject> for the attribute value's target object.  Returns a B<ERDBObject> for the attribute value's target object.
1944    
1945  =back  =back
1946    
# Line 1939  Line 2039 
2039      return $retVal;      return $retVal;
2040  }  }
2041    
2042    
2043    =head3 AttributeTable
2044    
2045    C<< my $tableHtml = CustomAttributes::AttributeTable($cgi, @attrList); >>
2046    
2047    Format the attribute data into an HTML table.
2048    
2049    =over 4
2050    
2051    =item cgi
2052    
2053    CGI query object used to generate the HTML
2054    
2055    =item attrList
2056    
2057    List of attribute results, in the format returned by the L</GetAttributes> or
2058    L</QueryAttributes> methods.
2059    
2060    =item RETURN
2061    
2062    Returns an HTML table displaying the attribute keys and values.
2063    
2064    =back
2065    
2066    =cut
2067    
2068    sub AttributeTable {
2069        # Get the parameters.
2070        my ($cgi, @attrList) = @_;
2071        # Accumulate the table rows.
2072        my @html = ();
2073        for my $attrData (@attrList) {
2074            # Format the object ID and key.
2075            my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];
2076            # Now we format the values. These remain unchanged unless one of them is a URL.
2077            my $lastValue = scalar(@{$attrData}) - 1;
2078            push @columns, map { $_ =~ /^http:/ ? $cgi->a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];
2079            # Assemble the values into a table row.
2080            push @html, $cgi->Tr($cgi->td(\@columns));
2081        }
2082        # Format the table in the return variable.
2083        my $retVal = $cgi->table({ border => 2 }, $cgi->Tr($cgi->th(['Object', 'Key', 'Values'])), @html);
2084        # Return it.
2085        return $retVal;
2086    }
2087  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3