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

Annotation of /Sprout/AttributeTest.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (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 Cwd;
50 :     use File::Copy;
51 :     use File::Path;
52 :     use FIG;
53 :     use CustomAttributes;
54 : parrello 1.3 use Time::HiRes qw ( time alarm sleep );
55 : parrello 1.1
56 :     # Get the command-line options and parameters.
57 : parrello 1.5 my ($options, @parameters) = StandardSetup([qw(CustomAttributes ERDB DBKernel) ],
58 : parrello 1.1 {
59 : parrello 1.2 trace => [2, "trace level"],
60 : parrello 1.1 phone => ["", "phone number (international format) to call when load finishes"],
61 :     },
62 :     "",
63 :     @ARGV);
64 :     # Set a variable to contain return type information.
65 :     my $rtype;
66 : parrello 1.2 # Get the CustomAttributes object.
67 : parrello 1.5 my $ca = CustomAttributes->new();
68 : parrello 1.1 # Insure we catch errors.
69 :     eval {
70 :     # Insure the attribute server is local.
71 :     if (ref $ca ne 'CustomAttributes') {
72 :     Confess("This test must be run on a local attribute server.");
73 :     } else {
74 :     # Build a hash of the data we want to put into the attribute load file.
75 :     my %loadHash = (0 => "# This is a comment.",
76 :     'Family:aclame|cluster103' => ['egg', 'beaters'],
77 :     'Feature:fig|100226.1.peg.3361' => ['tadpole'],
78 :     'Genome:83333.1' => ['adult'],
79 :     1 => '',
80 :     'Subsystem:4-Hydroxyphenylacetic_acid_catabolic_pathway' => ['wiggle'],
81 :     'Role:1,4-alpha-glucan phosphorylase (EC 2.4.1.1)' => ['swim'],
82 :     'Genome:100226.1' => ['hip','hop']
83 :     );
84 :     # Create the load file.
85 :     my $loadFileName = "$FIG_Config::temp/FrogLoader$$.tbl";
86 :     Trace("Creating load file $loadFileName.") if T(2);
87 :     my $oh = Open(undef, ">$loadFileName");
88 :     # Loop through the hash of load values.
89 :     for my $key (keys %loadHash) {
90 :     my $value = $loadHash{$key};
91 :     # If the value is an array, we have an attribute value line.
92 :     if (ref $value eq 'ARRAY') {
93 :     # Format the ID.
94 :     $key =~ /([^:]+):(.+)/;
95 :     my $idValue = FIG::form_oid($1, $2);
96 :     # Format the value.
97 :     my $valueValue = join($ca->{splitter}, @{$value});
98 :     # Write the line.
99 : parrello 1.2 Tracer::PutLine($oh, [$idValue, 'Frog', $valueValue]);
100 : parrello 1.1 } else {
101 :     # Here we have a comment line.
102 :     Tracer::PutLine($oh, [$value]);
103 :     # Delete this line from the hash so we don't expect it when
104 :     # we test "get_attributes".
105 :     delete $loadHash{$key};
106 :     }
107 :     }
108 :     # Close the load file.
109 :     close $oh;
110 :     # Create the attribute.
111 :     my @groups = qw(Feature Genome);
112 :     Trace("Creating Frog attribute.") if T(2);
113 :     $ca->StoreAttributeKey('Frog', 'string',
114 :     "This attribute is a special one used to test the attribute system. It was created by the AttributeTest script.",
115 :     \@groups);
116 :     # Verify that it is in the correct groups.
117 :     my @allGroups = $ca->GetGroups();
118 :     for my $group (@allGroups) {
119 :     Trace("Checking group $group.") if T(3);
120 :     # Get the current group's attributes in a hash.
121 :     my %keys = $ca->GetAttributeData(group => $group);
122 :     # Find out if we should be in this group.
123 :     my $inGroup = grep { $_ eq $group } @groups;
124 :     if (! exists $keys{Frog} && $inGroup) {
125 :     Confess("Frog not found in $group group.");
126 :     } elsif (exists $keys{Frog} && ! $inGroup) {
127 :     Confess("Frog found in $group group.");
128 :     }
129 :     }
130 :     # Load the attribute.
131 :     Trace("Loading Frog data.") if T(3);
132 : parrello 1.2 my $stats = $ca->LoadAttributesFrom($loadFileName);
133 : parrello 1.1 # Now we need to test the data against what's in the hash. First we get the data.
134 : parrello 1.5 my @attributes = $ca->GetAttributes(undef, 'Frog');
135 : parrello 1.1 # 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.
137 :     for my $attributeRow (@attributes) {
138 :     # Get the ID from this row.
139 :     my @rowData = ();
140 :     push @rowData, @{$attributeRow};
141 :     my $idValue = shift @rowData;
142 :     # Parse it into an ID and type, then combine them to get the hash key.
143 :     my ($type, $id) = FIG::parse_oid($idValue);
144 :     my $hashKey = "$type:$id";
145 :     # Check the hash.
146 :     if (! exists $loadHash{$hashKey}) {
147 :     Confess("Object $type($id) not found in load hash.");
148 :     } else {
149 :     # Insure this is a Frog attribute.
150 :     my $key = shift @rowData;
151 :     if ($key ne 'Frog') {
152 :     Confess("Attribute key is $key, but it should be Frog.");
153 :     } else {
154 :     # Get the values for this key.
155 :     my $valueList = $loadHash{$hashKey};
156 :     my @valueData = ();
157 :     push @valueData, @{$valueList};
158 :     # Compare them against the actual values.
159 :     if (length(@valueData) != length(@rowData)) {
160 :     Confess("Row for $hashKey does not match length of row retrieved from get_attributes.");
161 :     } else {
162 :     for (my $i = 0; $i <= $#valueData; $i++) {
163 :     if ($rowData[$i] ne $valueData[$i]) {
164 :     Confess("Value at position $i in row for $hashKey has mismatched data.");
165 :     }
166 :     }
167 :     # Remove this key from the hash.
168 :     Trace("$hashKey processed in retrieval check.") if T(3);
169 :     delete $loadHash{$hashKey};
170 :     }
171 :     }
172 :     }
173 :     }
174 :     # Verify that the load hash is empty.
175 :     if (scalar(keys %loadHash)) {
176 :     my @keys = sort keys %loadHash;
177 :     Trace("Attribute object IDs not found: " . join(" ", @keys)) if T(0);
178 :     Confess("Not all expected attribute values were found.");
179 :     } else {
180 :     # Now we do an insert and a delete.
181 :     Trace("Insert/delete test.") if T(2);
182 :     # Create an attribute row.
183 :     my @testArray = ('Reaction:R00001', 'Frog', 'simplicity');
184 :     # Insert it into the database.
185 : parrello 1.5 $ca->AddAttribute(@testArray);
186 : parrello 1.1 # Verify that it's there.
187 : parrello 1.5 my @tuple = $ca->GetAttributes(@testArray);
188 : parrello 1.1 if (! @tuple) {
189 :     Confess("Insert failed.");
190 :     } else {
191 :     # Delete it.
192 : parrello 1.5 $ca->DeleteAttribute(@testArray);
193 : parrello 1.1 # Verify that it's gone.
194 : parrello 1.5 my @nonTuple = $ca->GetAttributes(@testArray);
195 : parrello 1.1 if (@nonTuple) {
196 :     Confess("Delete failed.");
197 :     } else {
198 : parrello 1.2 # Erase the key. We'll use it again in the subkey test, so we
199 :     # don't want to delete it.
200 :     $ca->EraseAttribute('Frog');
201 : parrello 1.1 # Verify that it has no values.
202 : parrello 1.5 my @values = $ca->GetAttributes(undef, 'Frog');
203 : parrello 1.1 if (@values) {
204 :     Confess("Not all Frog attributes were deleted.");
205 :     }
206 :     }
207 :     }
208 :     }
209 : parrello 1.2 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 : parrello 1.4 Trace("Creating test attributes.") if T(2);
222 : parrello 1.2 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);
344 : parrello 1.1 }
345 :     };
346 :    
347 :     if ($@) {
348 :     Trace("Script failed with error: $@") if T(0);
349 :     $rtype = "error";
350 :     } else {
351 :     Trace("Script complete.") if T(2);
352 :     $rtype = "no error";
353 :     }
354 : parrello 1.2 # 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 : parrello 1.1 if ($options->{phone}) {
362 :     my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");
363 :     if ($msgID) {
364 :     Trace("Phone message sent with ID $msgID.") if T(2);
365 :     } else {
366 :     Trace("Phone message not sent.") if T(2);
367 :     }
368 :     }
369 :    
370 : parrello 1.2 =head3 MatchLists
371 :    
372 : parrello 1.4 my $matchFlag = MatchLists($list1, $list2);
373 : parrello 1.2
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 : parrello 1.4 my $matchFlag = MatchListsOfLists($list1, $list2);
418 : parrello 1.2
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 : parrello 1.4 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3