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

Diff of /Sprout/AttributeTest.pl

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

revision 1.1, Fri Feb 9 22:58:32 2007 UTC revision 1.5, Wed Jan 23 00:54:45 2008 UTC
# Line 46  Line 46 
46    
47  use strict;  use strict;
48  use Tracer;  use Tracer;
 use DocUtils;  
 use TestUtils;  
49  use Cwd;  use Cwd;
50  use File::Copy;  use File::Copy;
51  use File::Path;  use File::Path;
52  use FIG;  use FIG;
53  use CustomAttributes;  use CustomAttributes;
54    use Time::HiRes qw ( time alarm sleep );
55    
56  # Get the command-line options and parameters.  # Get the command-line options and parameters.
57  my ($options, @parameters) = StandardSetup([qw(CustomAttributes) ],  my ($options, @parameters) = StandardSetup([qw(CustomAttributes ERDB DBKernel) ],
58                                             {                                             {
59                                                  trace => [2, "trace level"],
60                                                phone => ["", "phone number (international format) to call when load finishes"],                                                phone => ["", "phone number (international format) to call when load finishes"],
61                                             },                                             },
62                                             "",                                             "",
63                                             @ARGV);                                             @ARGV);
64  # Set a variable to contain return type information.  # Set a variable to contain return type information.
65  my $rtype;  my $rtype;
66    # Get the CustomAttributes object.
67    my $ca = CustomAttributes->new();
68  # Insure we catch errors.  # Insure we catch errors.
69  eval {  eval {
     # Get a FIG object.  
     my $fig = FIG->new();  
     # Get the CustomAttributes object.  
     my $ca = $fig->{_ca};  
70      # Insure the attribute server is local.      # Insure the attribute server is local.
71      if (ref $ca ne 'CustomAttributes') {      if (ref $ca ne 'CustomAttributes') {
72          Confess("This test must be run on a local attribute server.");          Confess("This test must be run on a local attribute server.");
# Line 98  Line 96 
96                  # Format the value.                  # Format the value.
97                  my $valueValue = join($ca->{splitter}, @{$value});                  my $valueValue = join($ca->{splitter}, @{$value});
98                  # Write the line.                  # Write the line.
99                  Tracer::PutLine($oh, [$idValue, $valueValue]);                  Tracer::PutLine($oh, [$idValue, 'Frog', $valueValue]);
100              } else {              } else {
101                  # Here we have a comment line.                  # Here we have a comment line.
102                  Tracer::PutLine($oh, [$value]);                  Tracer::PutLine($oh, [$value]);
# Line 131  Line 129 
129          }          }
130          # Load the attribute.          # Load the attribute.
131          Trace("Loading Frog data.") if T(3);          Trace("Loading Frog data.") if T(3);
132          my $ih = Open(undef, "<$loadFileName");          my $stats = $ca->LoadAttributesFrom($loadFileName);
         my $stats = $ca->LoadAttributeKey('Frog', $ih, 0, 1);  
133          # Now we need to test the data against what's in the hash. First we get the data.          # Now we need to test the data against what's in the hash. First we get the data.
134          my @attributes = $fig->get_attributes(undef, 'Frog');          my @attributes = $ca->GetAttributes(undef, 'Frog');
135          # Loop through the attributes, checking against the hash. As we find an attribute,          # Loop through the attributes, checking against the hash. As we find an attribute,
136          # we delete it from the hash. When we're done, the hash should be empty.          # we delete it from the hash. When we're done, the hash should be empty.
137          for my $attributeRow (@attributes) {          for my $attributeRow (@attributes) {
# Line 185  Line 182 
182              # Create an attribute row.              # Create an attribute row.
183              my @testArray = ('Reaction:R00001', 'Frog', 'simplicity');              my @testArray = ('Reaction:R00001', 'Frog', 'simplicity');
184              # Insert it into the database.              # Insert it into the database.
185              $fig->add_attribute(@testArray);              $ca->AddAttribute(@testArray);
186              # Verify that it's there.              # Verify that it's there.
187              my @tuple = $fig->get_attributes(@testArray);              my @tuple = $ca->GetAttributes(@testArray);
188              if (! @tuple) {              if (! @tuple) {
189                  Confess("Insert failed.");                  Confess("Insert failed.");
190              } else {              } else {
191                  # Delete it.                  # Delete it.
192                  $fig->delete_attribute(@testArray);                  $ca->DeleteAttribute(@testArray);
193                  # Verify that it's gone.                  # Verify that it's gone.
194                  my @nonTuple = $fig->get_attributes(@testArray);                  my @nonTuple = $ca->GetAttributes(@testArray);
195                  if (@nonTuple) {                  if (@nonTuple) {
196                      Confess("Delete failed.");                      Confess("Delete failed.");
197                  } else {                  } else {
198                      # Delete the key.                      # Erase the key. We'll use it again in the subkey test, so we
199                      $ca->DeleteAttributeKey('Frog');                      # don't want to delete it.
200                        $ca->EraseAttribute('Frog');
201                      # Verify that it has no values.                      # Verify that it has no values.
202                      my @values = $fig->get_attributes(undef, 'Frog');                      my @values = $ca->GetAttributes(undef, 'Frog');
203                      if (@values) {                      if (@values) {
204                          Confess("Not all Frog attributes were deleted.");                          Confess("Not all Frog attributes were deleted.");
                     } else {  
                         # Insure there is no Frog attribute.  
                         my %keys = $ca->GetAttributeData(name => 'Frog');  
                         if (exists $keys{Frog}) {  
                             Confess("Frog attribute was not deleted.");  
205                          }                          }
206                      }                      }
207                  }                  }
208              }              }
209            Trace("GetAttribute tests.") if T(2);
210            # Now we do a get-attribute test. First, we need two new attributes: Frog1 and Frog2.
211            $ca->StoreAttributeKey('Frog1', 'string',
212                                   'This is another test attribute. It is used for complex get-attribute testing, along with a second attribute called Frog2.',
213                                   []);
214            $ca->StoreAttributeKey('Frog2', 'text',
215                                   'This is the third test attribute. Its name is similar to the second attribute so we can test generic lookups.',
216                                   []);
217            # Clear any existing data.
218            $ca->EraseAttribute('Frog1');
219            $ca->EraseAttribute('Frog2');
220            # Now we create an array of data to insert.
221            Trace("Creating test attributes.") if T(2);
222            my @frogRows = (['fig|100226.1.peg.1', 'Frog1', 123,      456],
223                            ['fig|100226.1.peg.1', 'Frog1', 123,      567],
224                            ['fig|100226.1.peg.2', 'Frog2', 12,       4567],
225                            ['fig|100226.1.peg.2', 'Frog1', 'data1',  'data2',  'data3'],
226                            ['fig|100226.1.peg.3', 'Frog1', '12data', 'data3',  'data4'],
227                            ['fig|100226.1.peg.3', 'Frog1', 'data12', '3data3', '4data4'],
228                            ['fig|83333.1.peg.1',  'Frog1', 'data12', '3data3', '4data4'],
229                            ['fig|83333.1.peg.1',  'Frog2', 'data12', '3data3', '4data4'],
230                            ['fig|83333.1.peg.1',  'Frog1', 'abc123', '123abd', '44data'],
231                            ['fig|83333.1.peg.2',  'Frog2', '12data'],
232                            ['fig|83333.1.peg.3',  'Frog1', '12data']);
233            for my $frogRow (@frogRows) {
234                $ca->AddAttribute(@{$frogRow});
235            }
236            # Get all the frog data.
237            Trace("Get-all test.") if T(2);
238            my @frogData = $ca->GetAttributes(undef, 'Frog%');
239            # Verify that it matches.
240            if (! MatchListsOfLists(\@frogRows, \@frogData)) {
241                Confess("Not all expected frog data returned by generic search on key.");
242            }
243            # Get all the frog 2s for 100226.1.
244            Trace("Generic ID test.") if T(2);
245            my @expected = grep { $_->[0] =~ /^fig\|100226.1/ && $_->[1] eq 'Frog2' } @frogRows;
246            @frogData = $ca->GetAttributes("fig|100226.1%", 'Frog2');
247            if (! MatchListsOfLists(\@expected, \@frogData)) {
248                Confess("Generic search on object ID failed.");
249            }
250            # Get all the frog 1s with "data" in the first value.
251            Trace("Regular expression test.") if T(2);
252            @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /data/ } @frogRows;
253            @frogData = $ca->GetAttributes(undef, 'Frog1', '/data/');
254            if (! MatchListsOfLists(\@expected, \@frogData)) {
255                Confess("Regular expression search on value failed.");
256            }
257            # Get all the frog 1s with values that start with "12".
258            Trace("Generic value test.") if T(2);
259            @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /^12/ } @frogRows;
260            @frogData = $ca->GetAttributes(undef, 'Frog1', '12%');
261            if (! MatchListsOfLists(\@expected, \@frogData)) {
262                Confess("Generic value match failed.");
263            }
264            Trace("Deleting test keys.") if T(2);
265            # Delete the test keys.
266            $ca->DeleteAttributeKey('Frog1');
267            $ca->DeleteAttributeKey('Frog2');
268            # Insure they are gone.
269            my %keys = $ca->GetAttributeData(name => 'Frog');
270            if (exists $keys{Frog1}) {
271                Confess("Frog1 attribute was not deleted.");
272            } elsif (exists $keys{Frog2}) {
273                Confess("Frog2 attribute was not deleted.");
274            } else {
275                # Now we know the keys are gone. Is the data gone?
276                my @frog12Rows = $ca->GetAttributes(undef, ['Frog1','Frog2']);
277                if (@frog12Rows) {
278                    Confess("Not all Frog1 and Frog2 values were deleted.");
279                }
280            }
281            # Now we test the subkey facility. First, we need a load file.
282            my @froggyRows = (['aclame|cluster844','Frog::tadpole','test1'],
283                              ['aclame|cluster845','Frog','test2'],
284                              ['aclame|cluster846','Frog::egg','test3'],
285                              ['aclame|cluster849','Frog','test4'],
286                              ['aclame|cluster852','Frog::adult','test5'],
287                              ['aclame|cluster85','Frog::egg','test6'],
288                              ['aclame|cluster853','Frog::tadpole2','test7'],
289                              ['aclame|cluster854','Frog','test8'],
290                              ['aclame|cluster855','Frog::egg','test8']);
291            $oh = Open(undef, ">$loadFileName");
292            for my $froggyRow (@froggyRows) {
293                Tracer::PutLine($oh, $froggyRow);
294          }          }
295            close $oh;
296            # Load the Frog attribute from the load file. We will take this opportunity to test
297            # the object type and archive modes.
298            my $archiveFile = $ca->ArchiveFileName();
299            my $ih = Open(undef, "<$loadFileName");
300            $stats = $ca->LoadAttributesFrom($ih, archive => $archiveFile, objectType => 'Family');
301            Trace("Statistics from subkey test load.\n" . $stats->Show()) if T(2);
302            # Now do an ID fix on the froggy rows so they match what's in the database.
303            for my $froggyRow (@froggyRows) {
304                $froggyRow->[0] = "Family:$froggyRow->[0]";
305            }
306            # Verify the archive file.
307            $ih = Open(undef, "<$archiveFile");
308            my $rowNum = 0;
309            while (! eof $ih) {
310                # Get the current file line and the current row.
311                my @fileRow = Tracer::GetLine($ih);
312                my @frogRow = @{$froggyRows[$rowNum]};
313                # Insure they match.
314                if (! MatchLists(\@fileRow, \@frogRow)) {
315                    Confess("Archive mismatch for subkey test in line $rowNum of $archiveFile.");
316                } else {
317                    $rowNum++
318                }
319            }
320            close $ih;
321            # Now verify a generic frog retrieval. It's important at this point that Frog1 and Frog2
322            # have already been erased, or this test will fail.
323            Trace("Generic frog retrieval test.") if T(3);
324            @frogData = $ca->GetAttributes(undef, 'Frog%');
325            if (! MatchListsOfLists(\@froggyRows, \@frogData)) {
326                Confess("Generic frog retrieval failed in subkey test.");
327            }
328            # Next we do a generic subkey search.
329            Trace("Generic tadpole retrieval test.") if T(3);
330            @expected = grep { $_->[1] =~ /^Frog::tadpole/ } @froggyRows;
331            @frogData = $ca->GetAttributes(undef, 'Frog::tadpole%');
332            if (! MatchListsOfLists(\@expected, \@frogData)) {
333                Confess("Generic tadpole retrieval failed in subkey test.");
334            }
335            # Now an exact subkey search.
336            Trace("Exact subkey retrieval test.") if T(3);
337            @expected = grep { $_->[1] eq 'Frog::tadpole' } @froggyRows;
338            @frogData = $ca->GetAttributes(undef, 'Frog::tadpole');
339            if (! MatchListsOfLists(\@expected, \@frogData)) {
340                Confess("Exact tadpole retrieval failed in subkey test.");
341      }      }
342            # All done.
343      Trace("Test complete.") if T(2);      Trace("Test complete.") if T(2);
344        }
345  };  };
346    
347  if ($@) {  if ($@) {
# Line 226  Line 351 
351      Trace("Script complete.") if T(2);      Trace("Script complete.") if T(2);
352      $rtype = "no error";      $rtype = "no error";
353  }  }
354    # Delete any leftover frogs.
355    my %frogs = $ca->GetAttributeData(name => 'Frog');
356    for my $frog (keys %frogs) {
357        Trace("Deleting $frog attribute.") if T(3);
358        my $stats = $ca->DeleteAttributeKey($frog);
359        Trace("$frog deleted.\n" . $stats->Show()) if T(2);
360    }
361  if ($options->{phone}) {  if ($options->{phone}) {
362      my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");      my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");
363      if ($msgID) {      if ($msgID) {
# Line 235  Line 367 
367      }      }
368  }  }
369    
370    =head3 MatchLists
371    
372        my $matchFlag = MatchLists($list1, $list2);
373    
374    Return TRUE if the two lists have the same elements, else FALSE. The matching is done
375    purely stringwise.
376    
377    =over 4
378    
379    =item list1
380    
381    Reference to a list of items.
382    
383    =item list2
384    
385    Reference to another list of items.
386    
387    =item RETURN
388    
389    Returns TRUE if the lists have matching elements.
390    
391    =back
392    
393    =cut
394    
395    sub MatchLists {
396        # Get the parameters.
397        my ($list1, $list2) = @_;
398        # Declare the return variable.
399        my $retVal = 1;
400        # Get the lengths.
401        my $len1 = @{$list1};
402        my $len2 = @{$list2};
403        # We fail if the lengths are different.
404        if ($len1 != $len2) {
405            $retVal = 0;
406        } else {
407            # Compare the elements.
408            for (my $i = 0; $retVal && $i < $len1; $i++) {
409                $retVal = ($list1->[$i] eq $list2->[$i]);
410            }
411        }
412        return $retVal;
413    }
414    
415    =head3 MatchListsOfLists
416    
417        my $matchFlag = MatchListsOfLists($list1, $list2);
418    
419    Compares two lists of lists, ensuring that both of the main lists have matching elements (though not
420    necessarily in the same order.
421    
422    =over 4
423    
424    =item list1
425    
426    Reference to the first list of lists.
427    
428    =item list2
429    
430    Reference to the second list of lists.
431    
432    =item RETURN
433    
434    Returns TRUE if every sublist in the first list is found in the second list and vice versa.
435    
436    =back
437    
438    =cut
439    
440    sub MatchListsOfLists {
441        # Get the parameters.
442        my ($list1, $list2) = @_;
443        # Declare the return variable.
444        my $retVal = 1;
445        # Create a hash of the elements in the first list. When we find an element in the
446        # second list that matches an entry in the hash, we delete it. At the end, we return
447        # TRUE if every element in the second list has been found in the hash and there are
448        # no hash entries left.
449        my %list1Hash = ();
450        my $list1Len = @{$list1};
451        for (my $i = 0; $i < $list1Len; $i++) {
452            $list1Hash{$i} = $list1->[$i];
453        }
454        # Loop through the second list.
455        my $list2Len = @{$list2};
456        for (my $i = 0; $i < $list2Len && $retVal; $i++) {
457            my $list2Element = $list2->[$i];
458            # Find a match in the first list.
459            my $matchKey;
460            for (my $j = 0; $j < $list1Len && ! defined $matchKey; $j++) {
461                if (exists $list1Hash{$j}) {
462                    my $list1Element = $list1Hash{$j};
463                    if (MatchLists($list1Element, $list2Element)) {
464                        $matchKey = $j;
465                    }
466                }
467            }
468            # If we found a match, delete it from the hash. Otherwise, we've failed.
469            if (! defined $matchKey) {
470                $retVal = 0;
471            } else {
472                delete $list1Hash{$matchKey};
473            }
474        }
475        # If anything is left in the first hash, it's a failure. (Of course, it may already be
476        # a failure, but that doesn't change anything.)
477        if (scalar(keys %list1Hash)) {
478            $retVal = 0;
479        }
480        # Return the match indication.
481        return $retVal;
482    }
483    
484  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3