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

Annotation of /Sprout/AttributeTest.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3