[Bio] / Sprout / AttributeTest.pl Repository:
ViewVC logotype

View of /Sprout/AttributeTest.pl

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.2 - (download) (as text) (annotate)
Sun Feb 18 21:25:18 2007 UTC (13 years, 4 months ago) by parrello
Branch: MAIN
Changes since 1.1: +266 -17 lines
Added tests for subkey support.

#!/usr/bin/perl -w

=head1 Attribute Test Script

This method will run a short test of the attribute system. It will use a
dummy attribute called C<Frog> that will be created and deleted by this
test process.

The currently-supported command-line options are as follows.

=over 4

=item user

Name suffix to be used for log files. If omitted, the PID is used.

=item trace

Numeric trace level. A higher trace level causes more messages to appear. The
default trace level is 2. Tracing will be directly to the standard output
as well as to a C<trace>I<User>C<.log> file in the FIG temporary directory,
where I<User> is the value of the B<user> option above.

=item sql

If specified, turns on tracing of SQL activity.

=item background

Save the standard and error output to files. The files will be created
in the FIG temporary directory and will be named C<err>I<User>C<.log> and
C<out>I<User>C<.log>, respectively, where I<User> is the value of the
B<user> option above.

=item h

Display this command's parameters and options.

=item phone

Phone number to message when the script is complete.



use strict;
use Tracer;
use DocUtils;
use TestUtils;
use Cwd;
use File::Copy;
use File::Path;
use FIG;
use CustomAttributes;

# Get the command-line options and parameters.
my ($options, @parameters) = StandardSetup([qw(CustomAttributes) ],
                                              trace => [2, "trace level"],
                                              phone => ["", "phone number (international format) to call when load finishes"],
# Set a variable to contain return type information.
my $rtype;
# Get a FIG object.
my $fig = FIG->new();
# Get the CustomAttributes object.
my $ca = $fig->{_ca};
# Insure we catch errors.
eval {
    # Insure the attribute server is local.
    if (ref $ca ne 'CustomAttributes') {
        Confess("This test must be run on a local attribute server.");
    } else {
        # Build a hash of the data we want to put into the attribute load file.
        my %loadHash = (0 => "# This is a comment.",
                        'Family:aclame|cluster103' => ['egg', 'beaters'],
                        'Feature:fig|100226.1.peg.3361' => ['tadpole'],
                        'Genome:83333.1' => ['adult'],
                        1 => '',
                        'Subsystem:4-Hydroxyphenylacetic_acid_catabolic_pathway' => ['wiggle'],
                        'Role:1,4-alpha-glucan phosphorylase (EC' => ['swim'],
                        'Genome:100226.1' => ['hip','hop']
        # Create the load file.
        my $loadFileName = "$FIG_Config::temp/FrogLoader$$.tbl";
        Trace("Creating load file $loadFileName.") if T(2);
        my $oh = Open(undef, ">$loadFileName");
        # Loop through the hash of load values.
        for my $key (keys %loadHash) {
            my $value = $loadHash{$key};
            # If the value is an array, we have an attribute value line.
            if (ref $value eq 'ARRAY') {
                # Format the ID.
                $key =~ /([^:]+):(.+)/;
                my $idValue = FIG::form_oid($1, $2);
                # Format the value.
                my $valueValue = join($ca->{splitter}, @{$value});
                # Write the line.
                Tracer::PutLine($oh, [$idValue, 'Frog', $valueValue]);
            } else {
                # Here we have a comment line.
                Tracer::PutLine($oh, [$value]);
                # Delete this line from the hash so we don't expect it when
                # we test "get_attributes".
                delete $loadHash{$key};
        # Close the load file.
        close $oh;
        # Create the attribute.
        my @groups = qw(Feature Genome);
        Trace("Creating Frog attribute.") if T(2);
        $ca->StoreAttributeKey('Frog', 'string',
                               "This attribute is a special one used to test the attribute system. It was created by the AttributeTest script.",
        # Verify that it is in the correct groups.
        my @allGroups = $ca->GetGroups();
        for my $group (@allGroups) {
            Trace("Checking group $group.") if T(3);
            # Get the current group's attributes in a hash.
            my %keys = $ca->GetAttributeData(group => $group);
            # Find out if we should be in this group.
            my $inGroup = grep { $_ eq $group } @groups;
            if (! exists $keys{Frog} && $inGroup) {
                Confess("Frog not found in $group group.");
            } elsif (exists $keys{Frog} && ! $inGroup) {
                Confess("Frog found in $group group.");
        # Load the attribute.
        Trace("Loading Frog data.") if T(3);
        my $stats = $ca->LoadAttributesFrom($loadFileName);
        # Now we need to test the data against what's in the hash. First we get the data.
        my @attributes = $fig->get_attributes(undef, 'Frog');
        # Loop through the attributes, checking against the hash. As we find an attribute,
        # we delete it from the hash. When we're done, the hash should be empty.
        for my $attributeRow (@attributes) {
            # Get the ID from this row.
            my @rowData = ();
            push @rowData, @{$attributeRow};
            my $idValue = shift @rowData;
            # Parse it into an ID and type, then combine them to get the hash key.
            my ($type, $id) = FIG::parse_oid($idValue);
            my $hashKey = "$type:$id";
            # Check the hash.
            if (! exists $loadHash{$hashKey}) {
                Confess("Object $type($id) not found in load hash.");
            } else {
                # Insure this is a Frog attribute.
                my $key = shift @rowData;
                if ($key ne 'Frog') {
                    Confess("Attribute key is $key, but it should be Frog.");
                } else {
                    # Get the values for this key.
                    my $valueList = $loadHash{$hashKey};
                    my @valueData = ();
                    push @valueData, @{$valueList};
                    # Compare them against the actual values.
                    if (length(@valueData) != length(@rowData)) {
                        Confess("Row for $hashKey does not match length of row retrieved from get_attributes.");
                    } else {
                        for (my $i = 0; $i <= $#valueData; $i++) {
                            if ($rowData[$i] ne $valueData[$i]) {
                                Confess("Value at position $i in row for $hashKey has mismatched data.");
                        # Remove this key from the hash.
                        Trace("$hashKey processed in retrieval check.") if T(3);
                        delete $loadHash{$hashKey};
        # Verify that the load hash is empty.
        if (scalar(keys %loadHash)) {
            my @keys = sort keys %loadHash;
            Trace("Attribute object IDs not found: " . join(" ", @keys)) if T(0);
            Confess("Not all expected attribute values were found.");
        } else {
            # Now we do an insert and a delete.
            Trace("Insert/delete test.") if T(2);
            # Create an attribute row.
            my @testArray = ('Reaction:R00001', 'Frog', 'simplicity');
            # Insert it into the database.
            # Verify that it's there.
            my @tuple = $fig->get_attributes(@testArray);
            if (! @tuple) {
                Confess("Insert failed.");
            } else {
                # Delete it.
                # Verify that it's gone.
                my @nonTuple = $fig->get_attributes(@testArray);
                if (@nonTuple) {
                    Confess("Delete failed.");
                } else {
                    # Erase the key. We'll use it again in the subkey test, so we
                    # don't want to delete it.
                    # Verify that it has no values.
                    my @values = $fig->get_attributes(undef, 'Frog');
                    if (@values) {
                        Confess("Not all Frog attributes were deleted.");
        Trace("GetAttribute tests.") if T(2);
        # Now we do a get-attribute test. First, we need two new attributes: Frog1 and Frog2.
        $ca->StoreAttributeKey('Frog1', 'string',
                               'This is another test attribute. It is used for complex get-attribute testing, along with a second attribute called Frog2.',
        $ca->StoreAttributeKey('Frog2', 'text',
                               'This is the third test attribute. Its name is similar to the second attribute so we can test generic lookups.',
        # Clear any existing data.
        # Now we create an array of data to insert.
        Trace("Creating test attributes.") if T(2);              
        my @frogRows = (['fig|100226.1.peg.1', 'Frog1', 123,      456],
                        ['fig|100226.1.peg.1', 'Frog1', 123,      567],
                        ['fig|100226.1.peg.2', 'Frog2', 12,       4567],
                        ['fig|100226.1.peg.2', 'Frog1', 'data1',  'data2',  'data3'],
                        ['fig|100226.1.peg.3', 'Frog1', '12data', 'data3',  'data4'],
                        ['fig|100226.1.peg.3', 'Frog1', 'data12', '3data3', '4data4'],
                        ['fig|83333.1.peg.1',  'Frog1', 'data12', '3data3', '4data4'],
                        ['fig|83333.1.peg.1',  'Frog2', 'data12', '3data3', '4data4'],
                        ['fig|83333.1.peg.1',  'Frog1', 'abc123', '123abd', '44data'],
                        ['fig|83333.1.peg.2',  'Frog2', '12data'],
                        ['fig|83333.1.peg.3',  'Frog1', '12data']);
        for my $frogRow (@frogRows) {
        # Get all the frog data.
        Trace("Get-all test.") if T(2);
        my @frogData = $ca->GetAttributes(undef, 'Frog%');
        # Verify that it matches.
        if (! MatchListsOfLists(\@frogRows, \@frogData)) {
            Confess("Not all expected frog data returned by generic search on key.");
        # Get all the frog 2s for 100226.1.
        Trace("Generic ID test.") if T(2);
        my @expected = grep { $_->[0] =~ /^fig\|100226.1/ && $_->[1] eq 'Frog2' } @frogRows;
        @frogData = $ca->GetAttributes("fig|100226.1%", 'Frog2');
        if (! MatchListsOfLists(\@expected, \@frogData)) {
            Confess("Generic search on object ID failed.");
        # Get all the frog 1s with "data" in the first value.
        Trace("Regular expression test.") if T(2);
        @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /data/ } @frogRows;
        @frogData = $ca->GetAttributes(undef, 'Frog1', '/data/');
        if (! MatchListsOfLists(\@expected, \@frogData)) {
            Confess("Regular expression search on value failed.");
        # Get all the frog 1s with values that start with "12".
        Trace("Generic value test.") if T(2);
        @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /^12/ } @frogRows;
        @frogData = $ca->GetAttributes(undef, 'Frog1', '12%');
        if (! MatchListsOfLists(\@expected, \@frogData)) {
            Confess("Generic value match failed.");
        Trace("Deleting test keys.") if T(2);
        # Delete the test keys.
        # Insure they are gone.
        my %keys = $ca->GetAttributeData(name => 'Frog');
        if (exists $keys{Frog1}) {
            Confess("Frog1 attribute was not deleted.");
        } elsif (exists $keys{Frog2}) {
            Confess("Frog2 attribute was not deleted.");
        } else {
            # Now we know the keys are gone. Is the data gone?
            my @frog12Rows = $ca->GetAttributes(undef, ['Frog1','Frog2']);
            if (@frog12Rows) {
                Confess("Not all Frog1 and Frog2 values were deleted.");
        # Now we test the subkey facility. First, we need a load file.
        my @froggyRows = (['aclame|cluster844','Frog::tadpole','test1'],
        $oh = Open(undef, ">$loadFileName");
        for my $froggyRow (@froggyRows) {
            Tracer::PutLine($oh, $froggyRow);
        close $oh;
        # Load the Frog attribute from the load file. We will take this opportunity to test
        # the object type and archive modes.
        my $archiveFile = $ca->ArchiveFileName();
        my $ih = Open(undef, "<$loadFileName");
        $stats = $ca->LoadAttributesFrom($ih, archive => $archiveFile, objectType => 'Family');
        Trace("Statistics from subkey test load.\n" . $stats->Show()) if T(2);
        # Now do an ID fix on the froggy rows so they match what's in the database.
        for my $froggyRow (@froggyRows) {
            $froggyRow->[0] = "Family:$froggyRow->[0]";
        # Verify the archive file.
        $ih = Open(undef, "<$archiveFile");
        my $rowNum = 0;
        while (! eof $ih) {
            # Get the current file line and the current row.
            my @fileRow = Tracer::GetLine($ih);
            my @frogRow = @{$froggyRows[$rowNum]};
            # Insure they match.
            if (! MatchLists(\@fileRow, \@frogRow)) {
                Confess("Archive mismatch for subkey test in line $rowNum of $archiveFile.");
            } else {
        close $ih;
        # Now verify a generic frog retrieval. It's important at this point that Frog1 and Frog2
        # have already been erased, or this test will fail.
        Trace("Generic frog retrieval test.") if T(3);
        @frogData = $ca->GetAttributes(undef, 'Frog%');
        if (! MatchListsOfLists(\@froggyRows, \@frogData)) {
            Confess("Generic frog retrieval failed in subkey test.");
        # Next we do a generic subkey search.
        Trace("Generic tadpole retrieval test.") if T(3);
        @expected = grep { $_->[1] =~ /^Frog::tadpole/ } @froggyRows;
        @frogData = $ca->GetAttributes(undef, 'Frog::tadpole%');
        if (! MatchListsOfLists(\@expected, \@frogData)) {
            Confess("Generic tadpole retrieval failed in subkey test.");
        # Now an exact subkey search.
        Trace("Exact subkey retrieval test.") if T(3);
        @expected = grep { $_->[1] eq 'Frog::tadpole' } @froggyRows;
        @frogData = $ca->GetAttributes(undef, 'Frog::tadpole');
        if (! MatchListsOfLists(\@expected, \@frogData)) {
            Confess("Exact tadpole retrieval failed in subkey test.");
        # All done.
        Trace("Test complete.") if T(2);

if ($@) {
    Trace("Script failed with error: $@") if T(0);
    $rtype = "error";
} else {
    Trace("Script complete.") if T(2);
    $rtype = "no error";
# Delete any leftover frogs.
my %frogs = $ca->GetAttributeData(name => 'Frog');
for my $frog (keys %frogs) {
    Trace("Deleting $frog attribute.") if T(3);
    my $stats = $ca->DeleteAttributeKey($frog);
    Trace("$frog deleted.\n" . $stats->Show()) if T(2);
if ($options->{phone}) {
    my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");
    if ($msgID) {
        Trace("Phone message sent with ID $msgID.") if T(2);
    } else {
        Trace("Phone message not sent.") if T(2);

=head3 MatchLists

C<< my $matchFlag = MatchLists($list1, $list2); >>

Return TRUE if the two lists have the same elements, else FALSE. The matching is done
purely stringwise.

=over 4

=item list1

Reference to a list of items.

=item list2

Reference to another list of items.

=item RETURN

Returns TRUE if the lists have matching elements.



sub MatchLists {
    # Get the parameters.
    my ($list1, $list2) = @_;
    # Declare the return variable.
    my $retVal = 1;
    # Get the lengths.
    my $len1 = @{$list1};
    my $len2 = @{$list2};
    # We fail if the lengths are different.
    if ($len1 != $len2) {
        $retVal = 0;
    } else {
        # Compare the elements.
        for (my $i = 0; $retVal && $i < $len1; $i++) {
            $retVal = ($list1->[$i] eq $list2->[$i]);
    return $retVal;

=head3 MatchListsOfLists

C<< my $matchFlag = MatchListsOfLists($list1, $list2); >>

Compares two lists of lists, ensuring that both of the main lists have matching elements (though not
necessarily in the same order.

=over 4

=item list1

Reference to the first list of lists.

=item list2

Reference to the second list of lists.

=item RETURN

Returns TRUE if every sublist in the first list is found in the second list and vice versa.



sub MatchListsOfLists {
    # Get the parameters.
    my ($list1, $list2) = @_;
    # Declare the return variable.
    my $retVal = 1;
    # Create a hash of the elements in the first list. When we find an element in the
    # second list that matches an entry in the hash, we delete it. At the end, we return
    # TRUE if every element in the second list has been found in the hash and there are
    # no hash entries left.
    my %list1Hash = ();
    my $list1Len = @{$list1};
    for (my $i = 0; $i < $list1Len; $i++) {
        $list1Hash{$i} = $list1->[$i];
    # Loop through the second list.
    my $list2Len = @{$list2};
    for (my $i = 0; $i < $list2Len && $retVal; $i++) {
        my $list2Element = $list2->[$i];
        # Find a match in the first list.
        my $matchKey;
        for (my $j = 0; $j < $list1Len && ! defined $matchKey; $j++) {
            if (exists $list1Hash{$j}) {
                my $list1Element = $list1Hash{$j};
                if (MatchLists($list1Element, $list2Element)) {
                    $matchKey = $j;
        # If we found a match, delete it from the hash. Otherwise, we've failed.
        if (! defined $matchKey) {
            $retVal = 0;
        } else {
            delete $list1Hash{$matchKey};
    # If anything is left in the first hash, it's a failure. (Of course, it may already be
    # a failure, but that doesn't change anything.)
    if (scalar(keys %list1Hash)) {
        $retVal = 0;
    # Return the match indication.
    return $retVal;


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3