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

Annotation of /Sprout/AttributeTest.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (view) (download) (as text)

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     =head1 Attribute Test Script
4 :    
5 :     This method will run a short test of the attribute system. It will use a
6 :     dummy attribute called C<Frog> that will be created and deleted by this
7 :     test process.
8 :    
9 :     The currently-supported command-line options are as follows.
10 :    
11 :     =over 4
12 :    
13 :     =item user
14 :    
15 :     Name suffix to be used for log files. If omitted, the PID is used.
16 :    
17 :     =item trace
18 :    
19 :     Numeric trace level. A higher trace level causes more messages to appear. The
20 :     default trace level is 2. Tracing will be directly to the standard output
21 :     as well as to a C<trace>I<User>C<.log> file in the FIG temporary directory,
22 :     where I<User> is the value of the B<user> option above.
23 :    
24 :     =item sql
25 :    
26 :     If specified, turns on tracing of SQL activity.
27 :    
28 :     =item background
29 :    
30 :     Save the standard and error output to files. The files will be created
31 :     in the FIG temporary directory and will be named C<err>I<User>C<.log> and
32 :     C<out>I<User>C<.log>, respectively, where I<User> is the value of the
33 :     B<user> option above.
34 :    
35 :     =item h
36 :    
37 :     Display this command's parameters and options.
38 :    
39 :     =item phone
40 :    
41 :     Phone number to message when the script is complete.
42 :    
43 :     =back
44 :    
45 :     =cut
46 :    
47 :     use strict;
48 :     use Tracer;
49 :     use DocUtils;
50 :     use TestUtils;
51 :     use Cwd;
52 :     use File::Copy;
53 :     use File::Path;
54 :     use FIG;
55 :     use CustomAttributes;
56 : parrello 1.3 use Time::HiRes qw ( time alarm sleep );
57 : parrello 1.1
58 :     # Get the command-line options and parameters.
59 :     my ($options, @parameters) = StandardSetup([qw(CustomAttributes) ],
60 :     {
61 : parrello 1.2 trace => [2, "trace level"],
62 : parrello 1.1 phone => ["", "phone number (international format) to call when load finishes"],
63 :     },
64 :     "",
65 :     @ARGV);
66 :     # Set a variable to contain return type information.
67 :     my $rtype;
68 : parrello 1.2 # Get a FIG object.
69 :     my $fig = FIG->new();
70 :     # Get the CustomAttributes object.
71 :     my $ca = $fig->{_ca};
72 : parrello 1.1 # Insure we catch errors.
73 :     eval {
74 :     # Insure the attribute server is local.
75 :     if (ref $ca ne 'CustomAttributes') {
76 :     Confess("This test must be run on a local attribute server.");
77 :     } else {
78 :     # Build a hash of the data we want to put into the attribute load file.
79 :     my %loadHash = (0 => "# This is a comment.",
80 :     'Family:aclame|cluster103' => ['egg', 'beaters'],
81 :     'Feature:fig|100226.1.peg.3361' => ['tadpole'],
82 :     'Genome:83333.1' => ['adult'],
83 :     1 => '',
84 :     'Subsystem:4-Hydroxyphenylacetic_acid_catabolic_pathway' => ['wiggle'],
85 :     'Role:1,4-alpha-glucan phosphorylase (EC 2.4.1.1)' => ['swim'],
86 :     'Genome:100226.1' => ['hip','hop']
87 :     );
88 :     # Create the load file.
89 :     my $loadFileName = "$FIG_Config::temp/FrogLoader$$.tbl";
90 :     Trace("Creating load file $loadFileName.") if T(2);
91 :     my $oh = Open(undef, ">$loadFileName");
92 :     # Loop through the hash of load values.
93 :     for my $key (keys %loadHash) {
94 :     my $value = $loadHash{$key};
95 :     # If the value is an array, we have an attribute value line.
96 :     if (ref $value eq 'ARRAY') {
97 :     # Format the ID.
98 :     $key =~ /([^:]+):(.+)/;
99 :     my $idValue = FIG::form_oid($1, $2);
100 :     # Format the value.
101 :     my $valueValue = join($ca->{splitter}, @{$value});
102 :     # Write the line.
103 : parrello 1.2 Tracer::PutLine($oh, [$idValue, 'Frog', $valueValue]);
104 : parrello 1.1 } else {
105 :     # Here we have a comment line.
106 :     Tracer::PutLine($oh, [$value]);
107 :     # Delete this line from the hash so we don't expect it when
108 :     # we test "get_attributes".
109 :     delete $loadHash{$key};
110 :     }
111 :     }
112 :     # Close the load file.
113 :     close $oh;
114 :     # Create the attribute.
115 :     my @groups = qw(Feature Genome);
116 :     Trace("Creating Frog attribute.") if T(2);
117 :     $ca->StoreAttributeKey('Frog', 'string',
118 :     "This attribute is a special one used to test the attribute system. It was created by the AttributeTest script.",
119 :     \@groups);
120 :     # Verify that it is in the correct groups.
121 :     my @allGroups = $ca->GetGroups();
122 :     for my $group (@allGroups) {
123 :     Trace("Checking group $group.") if T(3);
124 :     # Get the current group's attributes in a hash.
125 :     my %keys = $ca->GetAttributeData(group => $group);
126 :     # Find out if we should be in this group.
127 :     my $inGroup = grep { $_ eq $group } @groups;
128 :     if (! exists $keys{Frog} && $inGroup) {
129 :     Confess("Frog not found in $group group.");
130 :     } elsif (exists $keys{Frog} && ! $inGroup) {
131 :     Confess("Frog found in $group group.");
132 :     }
133 :     }
134 :     # Load the attribute.
135 :     Trace("Loading Frog data.") if T(3);
136 : parrello 1.2 my $stats = $ca->LoadAttributesFrom($loadFileName);
137 : parrello 1.1 # Now we need to test the data against what's in the hash. First we get the data.
138 :     my @attributes = $fig->get_attributes(undef, 'Frog');
139 :     # Loop through the attributes, checking against the hash. As we find an attribute,
140 :     # we delete it from the hash. When we're done, the hash should be empty.
141 :     for my $attributeRow (@attributes) {
142 :     # Get the ID from this row.
143 :     my @rowData = ();
144 :     push @rowData, @{$attributeRow};
145 :     my $idValue = shift @rowData;
146 :     # Parse it into an ID and type, then combine them to get the hash key.
147 :     my ($type, $id) = FIG::parse_oid($idValue);
148 :     my $hashKey = "$type:$id";
149 :     # Check the hash.
150 :     if (! exists $loadHash{$hashKey}) {
151 :     Confess("Object $type($id) not found in load hash.");
152 :     } else {
153 :     # Insure this is a Frog attribute.
154 :     my $key = shift @rowData;
155 :     if ($key ne 'Frog') {
156 :     Confess("Attribute key is $key, but it should be Frog.");
157 :     } else {
158 :     # Get the values for this key.
159 :     my $valueList = $loadHash{$hashKey};
160 :     my @valueData = ();
161 :     push @valueData, @{$valueList};
162 :     # Compare them against the actual values.
163 :     if (length(@valueData) != length(@rowData)) {
164 :     Confess("Row for $hashKey does not match length of row retrieved from get_attributes.");
165 :     } else {
166 :     for (my $i = 0; $i <= $#valueData; $i++) {
167 :     if ($rowData[$i] ne $valueData[$i]) {
168 :     Confess("Value at position $i in row for $hashKey has mismatched data.");
169 :     }
170 :     }
171 :     # Remove this key from the hash.
172 :     Trace("$hashKey processed in retrieval check.") if T(3);
173 :     delete $loadHash{$hashKey};
174 :     }
175 :     }
176 :     }
177 :     }
178 :     # Verify that the load hash is empty.
179 :     if (scalar(keys %loadHash)) {
180 :     my @keys = sort keys %loadHash;
181 :     Trace("Attribute object IDs not found: " . join(" ", @keys)) if T(0);
182 :     Confess("Not all expected attribute values were found.");
183 :     } else {
184 :     # Now we do an insert and a delete.
185 :     Trace("Insert/delete test.") if T(2);
186 :     # Create an attribute row.
187 :     my @testArray = ('Reaction:R00001', 'Frog', 'simplicity');
188 :     # Insert it into the database.
189 :     $fig->add_attribute(@testArray);
190 :     # Verify that it's there.
191 :     my @tuple = $fig->get_attributes(@testArray);
192 :     if (! @tuple) {
193 :     Confess("Insert failed.");
194 :     } else {
195 :     # Delete it.
196 :     $fig->delete_attribute(@testArray);
197 :     # Verify that it's gone.
198 :     my @nonTuple = $fig->get_attributes(@testArray);
199 :     if (@nonTuple) {
200 :     Confess("Delete failed.");
201 :     } else {
202 : parrello 1.2 # Erase the key. We'll use it again in the subkey test, so we
203 :     # don't want to delete it.
204 :     $ca->EraseAttribute('Frog');
205 : parrello 1.1 # Verify that it has no values.
206 :     my @values = $fig->get_attributes(undef, 'Frog');
207 :     if (@values) {
208 :     Confess("Not all Frog attributes were deleted.");
209 :     }
210 :     }
211 :     }
212 :     }
213 : parrello 1.2 Trace("GetAttribute tests.") if T(2);
214 :     # Now we do a get-attribute test. First, we need two new attributes: Frog1 and Frog2.
215 :     $ca->StoreAttributeKey('Frog1', 'string',
216 :     'This is another test attribute. It is used for complex get-attribute testing, along with a second attribute called Frog2.',
217 :     []);
218 :     $ca->StoreAttributeKey('Frog2', 'text',
219 :     'This is the third test attribute. Its name is similar to the second attribute so we can test generic lookups.',
220 :     []);
221 :     # Clear any existing data.
222 :     $ca->EraseAttribute('Frog1');
223 :     $ca->EraseAttribute('Frog2');
224 :     # Now we create an array of data to insert.
225 :     Trace("Creating test attributes.") if T(2);
226 :     my @frogRows = (['fig|100226.1.peg.1', 'Frog1', 123, 456],
227 :     ['fig|100226.1.peg.1', 'Frog1', 123, 567],
228 :     ['fig|100226.1.peg.2', 'Frog2', 12, 4567],
229 :     ['fig|100226.1.peg.2', 'Frog1', 'data1', 'data2', 'data3'],
230 :     ['fig|100226.1.peg.3', 'Frog1', '12data', 'data3', 'data4'],
231 :     ['fig|100226.1.peg.3', 'Frog1', 'data12', '3data3', '4data4'],
232 :     ['fig|83333.1.peg.1', 'Frog1', 'data12', '3data3', '4data4'],
233 :     ['fig|83333.1.peg.1', 'Frog2', 'data12', '3data3', '4data4'],
234 :     ['fig|83333.1.peg.1', 'Frog1', 'abc123', '123abd', '44data'],
235 :     ['fig|83333.1.peg.2', 'Frog2', '12data'],
236 :     ['fig|83333.1.peg.3', 'Frog1', '12data']);
237 :     for my $frogRow (@frogRows) {
238 :     $ca->AddAttribute(@{$frogRow});
239 :     }
240 :     # Get all the frog data.
241 :     Trace("Get-all test.") if T(2);
242 :     my @frogData = $ca->GetAttributes(undef, 'Frog%');
243 :     # Verify that it matches.
244 :     if (! MatchListsOfLists(\@frogRows, \@frogData)) {
245 :     Confess("Not all expected frog data returned by generic search on key.");
246 :     }
247 :     # Get all the frog 2s for 100226.1.
248 :     Trace("Generic ID test.") if T(2);
249 :     my @expected = grep { $_->[0] =~ /^fig\|100226.1/ && $_->[1] eq 'Frog2' } @frogRows;
250 :     @frogData = $ca->GetAttributes("fig|100226.1%", 'Frog2');
251 :     if (! MatchListsOfLists(\@expected, \@frogData)) {
252 :     Confess("Generic search on object ID failed.");
253 :     }
254 :     # Get all the frog 1s with "data" in the first value.
255 :     Trace("Regular expression test.") if T(2);
256 :     @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /data/ } @frogRows;
257 :     @frogData = $ca->GetAttributes(undef, 'Frog1', '/data/');
258 :     if (! MatchListsOfLists(\@expected, \@frogData)) {
259 :     Confess("Regular expression search on value failed.");
260 :     }
261 :     # Get all the frog 1s with values that start with "12".
262 :     Trace("Generic value test.") if T(2);
263 :     @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /^12/ } @frogRows;
264 :     @frogData = $ca->GetAttributes(undef, 'Frog1', '12%');
265 :     if (! MatchListsOfLists(\@expected, \@frogData)) {
266 :     Confess("Generic value match failed.");
267 :     }
268 :     Trace("Deleting test keys.") if T(2);
269 :     # Delete the test keys.
270 :     $ca->DeleteAttributeKey('Frog1');
271 :     $ca->DeleteAttributeKey('Frog2');
272 :     # Insure they are gone.
273 :     my %keys = $ca->GetAttributeData(name => 'Frog');
274 :     if (exists $keys{Frog1}) {
275 :     Confess("Frog1 attribute was not deleted.");
276 :     } elsif (exists $keys{Frog2}) {
277 :     Confess("Frog2 attribute was not deleted.");
278 :     } else {
279 :     # Now we know the keys are gone. Is the data gone?
280 :     my @frog12Rows = $ca->GetAttributes(undef, ['Frog1','Frog2']);
281 :     if (@frog12Rows) {
282 :     Confess("Not all Frog1 and Frog2 values were deleted.");
283 :     }
284 :     }
285 :     # Now we test the subkey facility. First, we need a load file.
286 :     my @froggyRows = (['aclame|cluster844','Frog::tadpole','test1'],
287 :     ['aclame|cluster845','Frog','test2'],
288 :     ['aclame|cluster846','Frog::egg','test3'],
289 :     ['aclame|cluster849','Frog','test4'],
290 :     ['aclame|cluster852','Frog::adult','test5'],
291 :     ['aclame|cluster85','Frog::egg','test6'],
292 :     ['aclame|cluster853','Frog::tadpole2','test7'],
293 :     ['aclame|cluster854','Frog','test8'],
294 :     ['aclame|cluster855','Frog::egg','test8']);
295 :     $oh = Open(undef, ">$loadFileName");
296 :     for my $froggyRow (@froggyRows) {
297 :     Tracer::PutLine($oh, $froggyRow);
298 :     }
299 :     close $oh;
300 :     # Load the Frog attribute from the load file. We will take this opportunity to test
301 :     # the object type and archive modes.
302 :     my $archiveFile = $ca->ArchiveFileName();
303 :     my $ih = Open(undef, "<$loadFileName");
304 :     $stats = $ca->LoadAttributesFrom($ih, archive => $archiveFile, objectType => 'Family');
305 :     Trace("Statistics from subkey test load.\n" . $stats->Show()) if T(2);
306 :     # Now do an ID fix on the froggy rows so they match what's in the database.
307 :     for my $froggyRow (@froggyRows) {
308 :     $froggyRow->[0] = "Family:$froggyRow->[0]";
309 :     }
310 :     # Verify the archive file.
311 :     $ih = Open(undef, "<$archiveFile");
312 :     my $rowNum = 0;
313 :     while (! eof $ih) {
314 :     # Get the current file line and the current row.
315 :     my @fileRow = Tracer::GetLine($ih);
316 :     my @frogRow = @{$froggyRows[$rowNum]};
317 :     # Insure they match.
318 :     if (! MatchLists(\@fileRow, \@frogRow)) {
319 :     Confess("Archive mismatch for subkey test in line $rowNum of $archiveFile.");
320 :     } else {
321 :     $rowNum++
322 :     }
323 :     }
324 :     close $ih;
325 :     # Now verify a generic frog retrieval. It's important at this point that Frog1 and Frog2
326 :     # have already been erased, or this test will fail.
327 :     Trace("Generic frog retrieval test.") if T(3);
328 :     @frogData = $ca->GetAttributes(undef, 'Frog%');
329 :     if (! MatchListsOfLists(\@froggyRows, \@frogData)) {
330 :     Confess("Generic frog retrieval failed in subkey test.");
331 :     }
332 :     # Next we do a generic subkey search.
333 :     Trace("Generic tadpole retrieval test.") if T(3);
334 :     @expected = grep { $_->[1] =~ /^Frog::tadpole/ } @froggyRows;
335 :     @frogData = $ca->GetAttributes(undef, 'Frog::tadpole%');
336 :     if (! MatchListsOfLists(\@expected, \@frogData)) {
337 :     Confess("Generic tadpole retrieval failed in subkey test.");
338 :     }
339 :     # Now an exact subkey search.
340 :     Trace("Exact subkey retrieval test.") if T(3);
341 :     @expected = grep { $_->[1] eq 'Frog::tadpole' } @froggyRows;
342 :     @frogData = $ca->GetAttributes(undef, 'Frog::tadpole');
343 :     if (! MatchListsOfLists(\@expected, \@frogData)) {
344 :     Confess("Exact tadpole retrieval failed in subkey test.");
345 :     }
346 :     # All done.
347 :     Trace("Test complete.") if T(2);
348 : parrello 1.1 }
349 :     };
350 :    
351 :     if ($@) {
352 :     Trace("Script failed with error: $@") if T(0);
353 :     $rtype = "error";
354 :     } else {
355 :     Trace("Script complete.") if T(2);
356 :     $rtype = "no error";
357 :     }
358 : parrello 1.2 # Delete any leftover frogs.
359 :     my %frogs = $ca->GetAttributeData(name => 'Frog');
360 :     for my $frog (keys %frogs) {
361 :     Trace("Deleting $frog attribute.") if T(3);
362 :     my $stats = $ca->DeleteAttributeKey($frog);
363 :     Trace("$frog deleted.\n" . $stats->Show()) if T(2);
364 :     }
365 : parrello 1.1 if ($options->{phone}) {
366 :     my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");
367 :     if ($msgID) {
368 :     Trace("Phone message sent with ID $msgID.") if T(2);
369 :     } else {
370 :     Trace("Phone message not sent.") if T(2);
371 :     }
372 :     }
373 :    
374 : parrello 1.2 =head3 MatchLists
375 :    
376 :     C<< my $matchFlag = MatchLists($list1, $list2); >>
377 :    
378 :     Return TRUE if the two lists have the same elements, else FALSE. The matching is done
379 :     purely stringwise.
380 :    
381 :     =over 4
382 :    
383 :     =item list1
384 :    
385 :     Reference to a list of items.
386 :    
387 :     =item list2
388 :    
389 :     Reference to another list of items.
390 :    
391 :     =item RETURN
392 :    
393 :     Returns TRUE if the lists have matching elements.
394 :    
395 :     =back
396 :    
397 :     =cut
398 :    
399 :     sub MatchLists {
400 :     # Get the parameters.
401 :     my ($list1, $list2) = @_;
402 :     # Declare the return variable.
403 :     my $retVal = 1;
404 :     # Get the lengths.
405 :     my $len1 = @{$list1};
406 :     my $len2 = @{$list2};
407 :     # We fail if the lengths are different.
408 :     if ($len1 != $len2) {
409 :     $retVal = 0;
410 :     } else {
411 :     # Compare the elements.
412 :     for (my $i = 0; $retVal && $i < $len1; $i++) {
413 :     $retVal = ($list1->[$i] eq $list2->[$i]);
414 :     }
415 :     }
416 :     return $retVal;
417 :     }
418 :    
419 :     =head3 MatchListsOfLists
420 :    
421 :     C<< my $matchFlag = MatchListsOfLists($list1, $list2); >>
422 :    
423 :     Compares two lists of lists, ensuring that both of the main lists have matching elements (though not
424 :     necessarily in the same order.
425 :    
426 :     =over 4
427 :    
428 :     =item list1
429 :    
430 :     Reference to the first list of lists.
431 :    
432 :     =item list2
433 :    
434 :     Reference to the second list of lists.
435 :    
436 :     =item RETURN
437 :    
438 :     Returns TRUE if every sublist in the first list is found in the second list and vice versa.
439 :    
440 :     =back
441 :    
442 :     =cut
443 :    
444 :     sub MatchListsOfLists {
445 :     # Get the parameters.
446 :     my ($list1, $list2) = @_;
447 :     # Declare the return variable.
448 :     my $retVal = 1;
449 :     # Create a hash of the elements in the first list. When we find an element in the
450 :     # second list that matches an entry in the hash, we delete it. At the end, we return
451 :     # TRUE if every element in the second list has been found in the hash and there are
452 :     # no hash entries left.
453 :     my %list1Hash = ();
454 :     my $list1Len = @{$list1};
455 :     for (my $i = 0; $i < $list1Len; $i++) {
456 :     $list1Hash{$i} = $list1->[$i];
457 :     }
458 :     # Loop through the second list.
459 :     my $list2Len = @{$list2};
460 :     for (my $i = 0; $i < $list2Len && $retVal; $i++) {
461 :     my $list2Element = $list2->[$i];
462 :     # Find a match in the first list.
463 :     my $matchKey;
464 :     for (my $j = 0; $j < $list1Len && ! defined $matchKey; $j++) {
465 :     if (exists $list1Hash{$j}) {
466 :     my $list1Element = $list1Hash{$j};
467 :     if (MatchLists($list1Element, $list2Element)) {
468 :     $matchKey = $j;
469 :     }
470 :     }
471 :     }
472 :     # If we found a match, delete it from the hash. Otherwise, we've failed.
473 :     if (! defined $matchKey) {
474 :     $retVal = 0;
475 :     } else {
476 :     delete $list1Hash{$matchKey};
477 :     }
478 :     }
479 :     # If anything is left in the first hash, it's a failure. (Of course, it may already be
480 :     # a failure, but that doesn't change anything.)
481 :     if (scalar(keys %list1Hash)) {
482 :     $retVal = 0;
483 :     }
484 :     # Return the match indication.
485 :     return $retVal;
486 :     }
487 :    
488 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3