File Coverage

blib/lib/Bio/DB/HIV/HIVQueryHelper.pm
Criterion Covered Total %
statement 592 741 79.8
branch 216 358 60.3
condition 48 147 32.6
subroutine 63 75 84.0
pod 0 3 0.0
total 919 1324 69.4


line stmt bran cond sub pod time code
1             # $Id: HIVQueryHelper.pm 231 2008-12-11 14:32:00Z maj $
2             #
3             # BioPerl module for Bio::DB::HIV::HIVQueryHelper
4             #
5             # Please direct questions and support issues to
6             #
7             # Cared for by Mark A. Jensen
8             #
9             # Copyright Mark A. Jensen
10             #
11             # You may distribute this module under the same terms as perl itself
12              
13             # POD documentation - main docs before the code
14              
15             =head1 NAME
16              
17             Bio::DB::HIV::HIVQueryHelper - Routines and packages used by Bio::DB::HIV and
18             Bio::DB::Query::HIVQuery
19              
20             =head1 SYNOPSIS
21              
22             Used in Bio::DB::Query::HIVQuery. No need to use directly.
23              
24             =head1 DESCRIPTION
25              
26             C contains a number of packages for use
27             by L. Package C parses the
28             C file, and allows access to it in the context of the
29             relational database it represents (see APPENDIX for excruciating
30             detail). Packages C, C, and C together create the query
31             string parser that enables NCBI-like queries to be understood by
32             C. They provide objects and operators to
33             perform and simplify logical expressions involving C, C, and
34             C<()> and return hash structures that can be handled by
35             C routines.
36              
37             =head1 FEEDBACK
38              
39             =head2 Mailing Lists
40              
41             User feedback is an integral part of the evolution of this and other
42             Bioperl modules. Send your comments and suggestions preferably to
43             the Bioperl mailing list. Your participation is much appreciated.
44              
45             bioperl-l@bioperl.org - General discussion
46             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
47              
48             =head2 Support
49              
50             Please direct usage questions or support issues to the mailing list:
51              
52             I
53              
54             rather than to the module maintainer directly. Many experienced and
55             reponsive experts will be able look at the problem and quickly
56             address it. Please include a thorough description of the problem
57             with code and data examples if at all possible.
58              
59             =head2 Reporting Bugs
60              
61             Report bugs to the Bioperl bug tracking system to help us keep track
62             of the bugs and their resolution. Bug reports can be submitted via
63             the web:
64              
65             https://github.com/bioperl/bioperl-live/issues
66              
67             =head1 AUTHOR - Mark A. Jensen
68              
69             Email maj@fortinbras.us
70              
71             =head1 CONTRIBUTORS
72              
73             Mark A. Jensen
74              
75             =head1 APPENDIX
76              
77             The rest of the documentation details each of the contained packages.
78             Internal methods are usually preceded with a _
79              
80             =cut
81              
82             # Let the code begin...
83              
84             package Bio::DB::HIV::HIVQueryHelper;
85 2     2   871 use strict;
  2         2  
  2         55  
86 2     2   9 use Bio::Root::Root;
  2         2  
  2         80  
87              
88             # globals
89             BEGIN {
90             #exceptions
91 2     2   75 @Bio::QueryStringSyntax::Exception::ISA = qw( Bio::Root::Exception);
92             }
93              
94             1;
95              
96             =head2 HIVSchema - objects/methods to manipulate a version of the LANL HIV DB schema
97              
98             =head3 HIVSchema SYNOPSIS
99              
100             $schema = new HIVSchema( 'lanl-schema.xml' );
101             @tables = $schema->tables;
102             @validFields = $schema->fields;
103             @validAliases = $schema->aliases;
104             @query_aliases_for_coreceptor = $schema->aliases( 'SEQ_SAMple.SSAM_second_receptor' );
105             $pk_for_SequenceEntry = $schema->primarykey('SequenceEntry'); # returns 'SequenceEntry.SE_id'
106             $fk_for_SEQ_SAMple_to_SequenceEntry =
107             $schema->foreignkey('SEQ_SAMple', 'SequenceEntry'); # returns 'SEQ_SAMple.SSAM_SE_id'
108              
109             $table = $schema->tablepart('SEQ_SAMple.SSAM_badseq'); # returns 'SEQ_SAMple'
110             $column = $schema->columnpart('SEQ_SAMple.SSAM_badseq'); # returns 'SSAM_badseq'
111              
112             =head3 HIVSchema DESCRIPTION
113              
114             HIVSchema methods are used in L for table,
115             column, primary/foreign key manipulations based on the observed Los
116             Alamos HIV Sequence Database (LANL DB) naming conventions for their
117             CGI parameters. The schema is contained in an XML file
118             (C) which is read into an HIVSchema object, in turn a
119             property of the HIVQuery object. HIVSchema methods are used to build
120             correct cgi queries in a way that attempts to preserve the context of
121             the relational database the query parameters represent.
122              
123             =cut
124              
125             package # hide from PAUSE
126             HIVSchema;
127             # objects/methods to manipulate a version of the LANL HIV DB schema
128             # stored in XML
129 2     2   7 use XML::Simple;
  2         2  
  2         10  
130 2     2   143 use Bio::Root::Root;
  2         3  
  2         22  
131 2     2   5 use strict;
  2         2  
  2         3866  
132              
133             ### constructor
134              
135             =head3 HIVSchema CONSTRUCTOR
136              
137             =head4 HIVSchema::new
138              
139             Title : new
140             Usage : $schema = new HIVSchema( "lanl-schema.xml ");
141             Function:
142             Example :
143             Returns : an HIVSchema object
144             Args : XML filename
145              
146             =cut
147              
148             sub new {
149 3     3   147 my $class = shift;
150 3         8 my @args = @_;
151 3         5 my $self = {};
152 3 100       10 if ($args[0]) {
153 2         7 $self->{schema_ref} = loadHIVSchema($args[0]);
154             }
155 3         12 bless($self, $class);
156 3         22 return $self;
157             }
158              
159             ### object methods
160              
161             =head3 HIVSchema INSTANCE METHODS
162              
163             =head4 HIVSchema tables
164              
165             Title : tables
166             Usage : $schema->tables()
167             Function: get all table names in schema
168             Example :
169             Returns : array of table names
170             Args : none
171              
172             =cut
173              
174             sub tables {
175             # return array of all tables in schema
176 265     265   182 local $_;
177 265         208 my $self = shift;
178 265         210 my $sref = $self->{schema_ref};
179 265 50       349 Bio::Root::Root->throw("schema not initialized") unless $sref;
180 265         10677 my @k = grep(/\./, keys %$sref);
181 265         1090 my %ret;
182 265         303 foreach (@k) {
183 24380         39586 s/\..*$//;
184 24380         23854 $ret{$_}++;
185             }
186 265         2723 @k = sort keys %ret;
187 265         4548 return @k;
188             }
189              
190             =head4 HIVSchema columns
191              
192             Title : columns
193             Usage : $schema->columns( [$tablename] );
194             Function: return array of columns for specified table, or all columns in
195             schema, if called w/o args
196             Example :
197             Returns :
198             Args : tablename or fieldname string
199              
200             =cut
201              
202             sub columns {
203             # return array of columns for specified table
204             # all columns in schema, if called w/o args
205 0     0   0 local $_;
206 0         0 my $self = shift;
207 0         0 my ($tbl) = @_;
208 0         0 my $sref = $self->{schema_ref};
209 0 0       0 Bio::Root::Root->throw("schema not initialized") unless $sref;
210             # trim column name
211 0         0 $tbl =~ s/\..*$//;
212             # check if table exists
213 0 0       0 return () unless grep(/^$tbl$/i, $self->tables);
214 0         0 my @k = sort keys %$sref;
215 0         0 @k = grep (/^$tbl\./i, @k);
216 0         0 foreach (@k) {
217 0         0 s/^$tbl\.//;
218             }
219 0         0 return @k;
220             }
221              
222             =head4 HIVSchema fields
223              
224             Title : fields
225             Usage : $schema->fields();
226             Function: return array of all fields in schema, in format "table.column"
227             Example :
228             Returns : array of all fields
229             Args : none
230              
231             =cut
232              
233             sub fields {
234             # return array of all fields (Table.Column format) in schema
235 242     242   233 my $self = shift;
236 242         238 my $sref = $self->{schema_ref};
237 242 50       403 Bio::Root::Root->throw("schema not initialized") unless $sref;
238 242         190 my @k = sort keys %{$sref};
  242         11802  
239 242         24839 return @k;
240             }
241              
242             =head4 HIVSchema options
243              
244             Title : options
245             Usage : $schema->options(@fieldnames)
246             Function: get array of options (i.e., valid match data strings) available
247             to specified field
248             Example :
249             Returns : array of match data strings
250             Args : [array of] fieldname string[s] in "table.column" format
251              
252             =cut
253              
254             sub options {
255             # return array of options available to specified field
256 74     74   64 my $self = shift;
257 74         62 my ($sfield) = @_;
258 74         60 my $sref = $self->{schema_ref};
259 74 50       118 Bio::Root::Root->throw("schema not initialized") unless $sref;
260 74 100       174 return $$sref{$sfield}{option} ? @{$$sref{$sfield}{option}} : ();
  32         277  
261             }
262              
263             =head4 HIVSchema aliases
264              
265             Title : aliases
266             Usage : $schema->aliases(@fieldnames)
267             Function: get array of aliases to specified field[s]
268             Example :
269             Returns : array of valid query aliases for fields as spec'd in XML file
270             Args : [an array of] fieldname[s] in "table.column" format
271              
272             =cut
273              
274             sub aliases {
275             # return array of aliases to specified field
276 1232     1232   770 my $self = shift;
277 1232         827 my ($sfield) = @_;
278 1232         854 my $sref = $self->{schema_ref};
279 1232         720 my @ret;
280 1232 50       1351 Bio::Root::Root->throw("schema not initialized") unless $sref;
281 1232 100       1074 if ($sfield) {
282 1223 100       1825 return $$sref{$sfield}{alias} ? @{$$sref{$sfield}{alias}} : ();
  1103         4310  
283             }
284             else { # all valid aliases
285 9 100       15 map {push @ret, @{$$sref{$_}{alias}} if $$sref{$_}{alias}} $self->fields;
  873         1416  
  783         1657  
286 9         255 return @ret;
287             }
288             }
289              
290             =head4 HIVSchema ankh
291              
292             Title : ankh (annotation key hash)
293             Usage : $schema->ankh(@fieldnames)
294             Function: return a hash translating fields to annotation keys for the
295             spec'd fields.
296             (Annotation keys are used for parsing the tab-delimited response
297             to Bio::DB::Query::HIVQuery::_do_lanl_request.)
298             Example :
299             Returns : hash ref
300             Args : [an array of] fieldname[s] in "table.column" format
301              
302             =cut
303              
304             sub ankh {
305             # return hash translating sfields to annotation keys for specified sfield(s)
306 1     1   3 my $self = shift;
307 1         1 my %ret = ();
308 1         2 my @sfields = @_;
309 1         1 my $sref = $self->{schema_ref};
310 1 50       3 Bio::Root::Root->throw("schema not initialized") unless $sref;
311 1         1 foreach (@sfields) {
312 1 50       4 next unless $$sref{$_}{ankey};
313 1         4 $ret{$_} = {'ankey'=>$$sref{$_}{ankey},'antype'=>$$sref{$_}{antype}};
314             }
315 1         9 return %ret;
316             }
317              
318             =head4 HIVSchema tablepart
319              
320             Title : tablepart (alias: tbl)
321             Usage : $schema->tbl(@fieldnames)
322             Function: return the portion of the fieldname[s] that refer to the
323             db table
324             Example : $schema->tbl('SequenceEntry.SE_id'); # returns 'SequenceEntry'
325             Returns : table name as string
326             Args : [an array of] fieldname[s] in "table.column" format
327              
328             =cut
329              
330             sub tablepart {
331             # return the 'Table' part of the specified field(s)
332 6     6   7 my $self = shift;
333 6         14 my @sfields = @_;
334 6 50       17 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
335 6         7 my ($squish,@ret, %ret);
336 6 100       13 if ($sfields[0] eq '-s') {
337             # squish : remove duplicates from the returned array
338 5         5 $squish=1;
339 5         160 shift @sfields;
340             }
341 6         13 foreach (@sfields) {
342 32         79 push @ret, /^(.*)\./;
343             }
344 6 100       13 if ($squish) {
345             # arg order is clobbered
346 5         20 @ret{@ret} = undef;
347 5         13 @ret = keys %ret;
348             }
349 6 100       32 return (wantarray ? @ret : $ret[0]);
350             }
351              
352             sub tbl {
353             # tablepart alias
354 5     5   14 shift->tablepart(@_);
355             }
356              
357             =head4 HIVSchema columnpart
358              
359             Title : columnpart (alias: col)
360             Usage : $schema->col(@fieldnames)
361             Function: return the portion of the fieldname[s] that refer to the
362             db column
363             Example : $schema->col('SequenceEntry.SE_id'); # returns 'SE_id'
364             Returns : column name as string
365             Args : [an array of] fieldname[s] in "table.column" format
366              
367             =cut
368              
369             sub columnpart {
370             # return the 'Column' part of the specified field(s)
371 1     1   2 my $self = shift;
372 1         2 my @sfields = @_;
373 1 50       4 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
374 1         1 my @ret;
375 1         2 foreach (@sfields) {
376 1         8 push @ret, /\.(.*)$/;
377             }
378 1 50       5 return (wantarray ? @ret : $ret[0]);
379             }
380              
381             sub col {
382             # columnpart alias
383 0     0   0 shift->columnpart(@_);
384             }
385              
386             =head4 HIVSchema primarykey
387              
388             Title : primarykey [alias: pk]
389             Usage : $schema->pk(@tablenames);
390             Function: return the primary key of the specified table[s], as judged by
391             the syntax of the table's[s'] fieldnames
392             Example : $schema->pk('SequenceEntry') # returns 'SequenceEntry.SE_id'
393             Returns : primary key fieldname[s] in "table.column" format, or null if
394             no pk exists
395             Args : [an array of] table name[s] (fieldnames are ok, table part used)
396              
397             =cut
398              
399             sub primarykey {
400             # return the primary key (in Table.Column format) of specified table(s)
401 91     91   75 my $self = shift;
402 91         101 my @tbl = @_;
403 91         68 my @ret;
404 91 50       160 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
405 91         123 foreach my $tbl (@tbl) {
406             # trim column name
407 101         115 $tbl =~ s/\..*$//;
408 101 50       158 grep(/^$tbl$/i, $self->tables) ?
409             push(@ret, grep(/\.[0-9a-zA-Z]+_id/, grep(/$tbl/i,$self->fields))) :
410             push(@ret, "");
411             }
412 91 100       234 return (wantarray ? @ret : $ret[0]);
413             }
414              
415             sub pk {
416             # primarykey alias
417 20     20   36 shift->primarykey(@_);
418             }
419              
420             =head4 HIVSchema foreignkey
421              
422             Title : foreignkey [alias: fk]
423             Usage : $schema->fk($intable [, $totable])
424             Function: return foreign key fieldname in table $intable referring to
425             table $totable, or all foreign keys in $intable if $totable
426             unspec'd
427             Example : $schema->fk('AUthor', 'SequenceEntry'); # returns 'AUthor_AU_SE_id'
428             Returns : foreign key fieldname[s] in "table.column" format
429             Args : tablename [, optional foreign table name] (fieldnames are ok,
430             table part used)
431              
432             =cut
433              
434             sub foreignkey {
435             # return foreign key in in-table ($intbl) to to-table ($totbl)
436             # or all foreign keys in in-table if to-table not specified
437             # keys returned in Table.Column format
438 87     87   76 my $self = shift;
439 87         98 my ($intbl, $totbl) = @_;
440 87 50       140 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
441             # trim col names
442 87         88 $intbl =~ s/\..*$//;
443 87 100       234 $totbl =~ s/\..*$// if $totbl;
444             # check if in-table exists
445 87 50       126 return () unless grep( /^$intbl/i, $self->tables);
446 87         189 my @ret = grep( /$intbl\.(?:[0-9a-zA-Z]+_){2,}id/i, $self->fields);
447 87 100       431 if ($totbl) {
448 70         109 my $tpk = $self->primarykey($totbl);
449 70 0 33     112 return (wantarray ? () : "") unless grep( /^$totbl/i, $self->tables) && $tpk;
    50          
450 70         229 ($tpk) = ($tpk =~ /\.(.*)$/);
451 70         164 @ret = grep( /$tpk$/, @ret);
452 70 50       303 return (wantarray ? @ret : $ret[0]);
453             }
454             else {
455             # return all foreign keys in in-table
456 17         44 return @ret;
457             }
458             }
459              
460             sub fk {
461             # foreignkey alias
462 85     85   135 shift->foreignkey(@_);
463             }
464              
465             =head4 HIVSchema foreigntable
466              
467             Title : foreigntable [alias ftbl]
468             Usage : $schema->ftbl( @foreign_key_fieldnames );
469             Function: return tablename of table that foreign keys points to
470             Example : $schema->ftbl( 'AUthor.AU_SE_id' ); # returns 'SequenceEntry'
471             Returns : tablename
472             Args : [an array of] fieldname[s] in "table.column" format
473              
474             =cut
475              
476             sub foreigntable {
477             # return table name that foreign key(s) point(s) to
478 21     21   21 my $self = shift;
479 21         23 my @fk = @_;
480 21         18 my @ret;
481 21 50       39 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
482 21         26 foreach (@fk) {
483 21         92 my ($mnem, $fmnem) = /\.([0-9a-zA-Z]+)_([0-9a-zA-Z]+)_.*$/;
484 21 50 33     75 next unless $mnem && $fmnem;
485             # lookup based on Table.Column format of fields
486 21         30 my $sf = [grep( /^[0-9a-zA-Z]+\.$fmnem\_/, $self->fields )]->[0];
487 21 50       204 next unless $sf;
488 21         60 ($sf) = ($sf =~ /^([0-9a-zA-Z]+)\./);
489 21         40 push @ret, $sf;
490             }
491 21 100       71 return (wantarray ? @ret : $ret[0]);
492             }
493              
494             sub ftbl {
495             # foreigntable alias
496 20     20   38 shift->foreigntable(@_);
497             }
498              
499             =head4 HIVSchema find_join
500              
501             Title : find_join
502             Usage : $sch->find_join('Table1', 'Table2')
503             Function: Retrieves a set of foreign and primary keys (in table.column
504             format) that represents a join path from Table1 to Table2
505             Example :
506             Returns : an array of keys (as table.column strings) -or- an empty
507             array if Table1 == Table2 -or- undef if no path exists
508             Args : two table names as strings
509              
510             =cut
511              
512             sub find_join {
513 15     15   16 my $self = shift;
514 15         14 my ($tgt, $tbl) = @_;
515 15         27 my ($stack, $revstack, $found, $revcut) = ([],[], 0, 4);
516 15         20 $self->_find_join_guts($tgt, $tbl, $stack, \$found);
517 15 100       21 if ($found) {
518 10 50       19 if (@$stack > $revcut) {
519             # reverse order of tables, see if a shorter path emerges
520 0         0 $found = 0;
521 0         0 $self->_find_join_guts($tgt, $tbl, $revstack, \$found, 1);
522 0 0       0 return (@$stack <= @$revstack ? @$stack : @$revstack);
523             }
524 10         34 return @$stack;
525             }
526             else {
527 5         12 return undef;
528             }
529             }
530              
531             =head4 HIVSchema _find_join_guts
532              
533             Title : _find_join_guts
534             Usage : $sch->_find_join_guts($table1, $table2, $stackref, \$found, $reverse)
535             (call with $stackref = [], $found=0)
536             Function: recursive guts of find_join
537             Example :
538             Returns : if a path is found, $found==1 and @$stackref contains the keys
539             in table.column format representing the path; if a path is not
540             found, $found == 0 and @$stackref contains garbage
541             Args : $table1, $table2 : table names as strings
542             $stackref : an arrayref to an empty array
543             \$found : a scalar ref to the value 0
544             $rev : if $rev==1, the arrays of table names will be reversed;
545             this can give a shorter path if cycles exist in the
546             schema graph
547              
548             =cut
549              
550             sub _find_join_guts {
551 20     20   18 my $self = shift;
552 20         27 my ($tbl, $tgt, $stack, $found, $rev) = @_;
553 20 100       32 return () if $tbl eq $tgt;
554 15         19 my $k = $self->pk($tbl);
555 15 100       23 if ($k) {
556             # all fks pointing to pk
557             my @fk2pk = map {
558 5 100       14 $self->fk($_, $k) || ()
  70 50       120  
559             } ($rev ? reverse $self->tables : $self->tables);
560             # skip keys already on stack
561 5 50       18 if (@$stack) {
562 5 50       13 (@$stack == 1) && do {
563 5         37 @fk2pk = grep (!/$$stack[0]/, @fk2pk);
564             };
565 5 50       35 (@$stack > 1 ) && do {
566 0 0       0 @fk2pk = map { my $f=$_; grep(/$f/, @$stack) ? () : $f } @fk2pk;
  0         0  
  0         0  
567             };
568             }
569 5         12 foreach my $f2p (@fk2pk) { # tables with fks pointing to pk
570 0         0 push @$stack, $f2p;
571 0 0       0 if ($self->tbl($f2p) eq $tgt) { # this fk's table is the target
572             # found it
573 0         0 $$found = 1;
574 0         0 return;
575             }
576             else {
577             #keep looking
578 0         0 $self->_find_join_guts($self->tbl($f2p), $tgt, $stack, $found, $rev);
579 0 0       0 return if $$found;
580             }
581             }
582             }
583             # all fks in $tbl
584 15 50       35 my @fks = ($rev ? reverse $self->fk($tbl) : $self->fk($tbl));
585             #skip keys already on stack
586 15 100       31 if (@$stack) {
587 5 50       12 (@$stack == 1) && do {
588 5         6 @fks = grep(!/$$stack[0]/, @fks);
589             };
590 5 50       11 (@$stack > 1) && do {
591 0 0       0 @fks = map { my $f=$_; grep(/$f/, @$stack) ? () : $f } @fks;
  0         0  
  0         0  
592             };
593             }
594             # all fks in table
595 15 100       24 if (@fks) {
596 10         12 for my $f (@fks) {
597 15         20 push @$stack, $f;
598 15 100       27 if ($self->ftbl($f) eq $tgt) { #found it
599 10         12 $$found = 1;
600 10         18 return;
601             }
602             else {
603 5         8 $self->_find_join_guts($self->ftbl($f), $tgt, $stack, $found, $rev);
604 5 50       16 $$found ? return : pop @$stack;
605             }
606             }
607             }
608             else {
609 5         6 pop @$stack;
610 5         10 return;
611             }
612             }
613              
614             =head4 HIVSchema loadSchema
615              
616             Title : loadHIVSchema [alias: loadSchema]
617             Usage : $schema->loadSchema( $XMLfilename )
618             Function: read (LANL DB) schema spec from XML
619             Example : $schema->loadSchema('lanl-schema.xml');
620             Returns : hashref to schema data
621             Keys are fieldnames in "table.column" format.
622             Each value is a hashref with the following properties:
623             {name} : HIVWEB 'table.column' format fieldname,
624             can be used directly in the cgi query
625             {aliases} : ref to array containing valid aliases/shortcuts for
626             {name}; can be used in routines creating the HTML query
627             {options} : ref to array containing valid matchdata for this field
628             can be used directly in the HTML query
629             {ankey} : contains the annotation key for this field used with
630             Bioperl annotation objects
631             {..attr..}: ..value_of_attr.. for this field (app-specific metadata)
632             Args :
633              
634             =cut
635              
636             sub loadHIVSchema {
637 2     2   4 my $fn = shift;
638 2 50       37 Bio::Root::Root->throw("loadHIVSchema: schema file not found") unless -e $fn;
639 2         25 my $q = XML::Simple->new(ContentKey=>'name',NormalizeSpace=>2,ForceArray=>1);
640 2         170 my %ret;
641 2         8 my $ref = $q->XMLin($fn);
642 2         2377708 my @sf = keys %{$$ref{sfield}};
  2         489  
643 2         10 foreach (@sf) {
644 194         206 my $h = $$ref{sfield}{$_};
645 194         236 $ret{$_} = $h;
646 194         206 foreach my $ptr ($$h{option}, $$h{alias}) {
647 388 100       456 if ($ptr) {
648             # kludge for XMLin: appears to convert to arrays, if there
649             # exists a tag without content, but to convert to hashes
650             # with content as key, if all tags possess content
651 246 100       350 if (ref($ptr) eq 'HASH') {
    50          
652 66         50 my @k = keys %{$ptr};
  66         791  
653 66 50       85 if (grep /desc/, keys %{$ptr->{$k[0]}}) {
  66         229  
654             # slurp the desc's
655 66         56 $$h{desc} = [ map { $$ptr{$_}->{desc} } @k ];
  2426         2657  
656             }
657             # now overwrite with keys (descs in same order...)
658 66         941 $ptr = [@k];
659             }
660             elsif (ref($ptr) eq 'ARRAY') {
661 180 100       101 $ptr = [map { ref eq 'HASH' ? $_->{name} : $_ } @{$ptr}]
  408         641  
  180         170  
662             }
663             else {
664 0         0 1; # stub : doh!
665             }
666             }
667             }
668 194         185 for my $ptr ($$h{ankey}) {
669             # flatten
670 194         119 my $ank = [keys %{$ptr}]->[0];
  194         338  
671 194 100       240 if (!defined $ank) {
672 18         31 delete $$h{ankey};
673             }
674             else {
675 176         212 $h->{antype} = $ptr->{$ank}{antype};
676 176         324 $ptr = $ank;
677             }
678             }
679             }
680 2         68 return \%ret;
681             }
682              
683             sub loadSchema {
684 0     0   0 my $self = shift;
685 0         0 $self->{schema_ref} = loadHIVSchema(shift);
686             }
687              
688             # below, dangerous
689              
690             =head4 HIVSchema _sfieldh
691              
692             Title : _sfieldh
693             Usage : $schema->_sfieldh($fieldname)
694             Function: get hashref to the specified field hash
695             Example :
696             Returns : hashref
697             Args : fieldname in "table.column" format
698              
699             =cut
700              
701             sub _sfieldh {
702             # return reference to the specified field hash
703 15     15   15 my $self = shift;
704 15         11 my ($sfield) = @_;
705 15         13 return ${$self->{schema_ref}}{$sfield};
  15         37  
706             }
707              
708             1;
709              
710             =head2 Class QRY - a query algebra for HIVQuery
711              
712             =head3 QRY SYNOPSIS
713              
714             $Q = new QRY(
715             new R(
716             new Q('coreceptor', 'CXCR4'),
717             new Q('country', 'ZA')
718             )
719             );
720             QRY::Eq(QRY::And($Q, $Q), $Q); # returns 1
721             QRY::Eq(QRY::Or($Q, $Q), $Q); # returns 1
722             $Q2 = $Q1->clone;
723             $Q2 = new QRY(
724             new R(
725             new Q( 'coreceptor', 'CCR5' ),
726             new Q( 'country', 'ZA')
727             )
728             );
729             (QRY::And($Q, $Q2))->isnull; # returns 1
730             $Q3 = QRY::Or($Q, $Q2);
731             print $Q3->A; # prints '(CCR5 CXCR4)[coreceptor] (ZA)[country]'
732              
733             =head3 QRY DESCRIPTION
734              
735             The QRY package provides a query parser for
736             L. Currently, the parser supports AND, OR,
737             and () operations. The structure of the LANL cgi makes it tricky to
738             perform NOTs, though this could be implemented if the desire were
739             great.
740              
741             Two class methods do the work. C does a first-pass
742             parse of the query string. C interprets the parse tree
743             as returned by C and produces an array of hash
744             structures that can be used directly by C
745             query execution methods. Validation of query fields and options is
746             performed at the C level, not here.
747              
748             C objects are collections of C (or request) objects, which are
749             in turn collections of C (or atomic query) objects. C objects
750             represent a query on a single field, with match data options Ced
751             together, e.g. C<(A B)[subtype]>. C objects collect C objects
752             that could be processed in a single HTTP request; i.e., a set of
753             atomic queries each having different fields Ced together, such as
754              
755             (A B)[subtype] AND ('CCR5')[coreceptor] AND (US CA)[country]
756              
757             The C object collects Cs that cannot be reduced (through
758             logical operations) to a single HTTP request, e.g.
759              
760             ((C)[subtype] AND (SI)[phenotype]) OR ( (D)[subtype] AND (NSI)[phenotype] ),
761              
762             which cannot be got in one go through the current LANL cgi
763             implementation (as far as I can tell). The parser will simplify
764             something like
765              
766             ((C)[subtype] AND (SI)[phenotype]) OR ((C)[subtype] AND (NSI)[phenotype])
767              
768             to the single request
769              
770             (C)[subtype] AND (NSI SI)[phenotype]
771              
772             however.
773              
774             The operators C<&> and C<|> are overloaded to C and
775             C, to get Perl precedence and grouping for free. C is
776             overloaded to get symbolic tests such as C. C<==>
777             is overloaded with C for convenience. No overloading is done
778             for C or C.
779              
780             =cut
781              
782             # a query algebra for HIVQuery
783             #
784             # Each Q object is an 'atomic' query, written as (data)[field]
785             # (a b ...)[X] equals (a)[X] | (b)[X] | ...
786             # Each R object represents a single HTTP request to the db
787             # contains an array of Q (atomic) objects (q1, q2, ...)
788             # the R object is interpreted as q1 & q2 & ...
789             # Each QRY object represents a series of HTTP requests to the db
790             # contains an array of R (request) objects (R1, R2, ...)
791             # the QRY object is interpreted as R1 | R2 | ...
792             #
793             # & and | operations are specified for each type
794              
795             package # hide from PAUSE
796             QRY;
797 2     2   14 use strict;
  2         1  
  2         106  
798             $QRY::NULL = new QRY();
799              
800              
801             use overload
802 2         30 "|" => \&Or,
803             "&" => \&And,
804             "bool" => \&Bool,
805 2     2   9 "==" => \&Eq;
  2         3  
806              
807              
808             # query language emulator
809             # supports only AND and OR, any groupings
810             #
811             # syntax rules:
812             # query atom: bareword [field] OR (bareword ...) [field]
813             # only single bareword allowed between []
814             # annotation fields in {} (only bareword lists allowed between {})
815             # () can group query atoms joined by operators (AND or OR)
816             # () containing only barewords MUST be followed by a field descriptor [field]
817             # empty [] not allowed
818             # query atoms joined with AND by default
819             # barewords are associated (ORed within) the next field descriptor in the line
820              
821             # follow the parse tree, creating new QRY objects as needed in @q, and
822             # construct a logical expression using & and | symbols.
823             # These are overloaded for doing ands and ors on QRY objects;
824             # to get the final QRY object, eval the resulting expression $q_expr.
825             # QRY object will be translated into (possibly multiple) hashes
826             # conforming to HIVQuery parameter requirements.
827              
828             =head4 QRY _make_q
829              
830             Title : _make_q
831             Usage : QRY::_make_q($parsetree)
832             Function: creates hash structures suitable for HIVQuery from parse tree
833             returned by QRY::_parse_q
834             Example :
835             Returns : array of hashrefs of query specs
836             Args : a hashref
837              
838             =cut
839              
840             sub _make_q {
841 7     7   9 my $ptree = shift;
842 7         10 my ($q_expr, @q, @an, $query, @dbq);
843 7         16 _make_q_guts($ptree, \$q_expr, \@q, \@an);
844 7         382 $query = eval $q_expr;
845 7 50       39 throw Bio::Root::Root(-class=>'Bio::Root::Exception',
846             -text=>$@,
847             -value=>$q_expr) if $@;
848 7 100       15 return {} if $query->isnull;
849 6         10 foreach my $rq ($query->requests) {
850 9         14 my $h = {'query'=>{}};
851 9         17 foreach ($rq->atoms) {
852 19         25 my @d = split(/\s+/, $_->dta);
853 19         22 foreach my $d (@d) {
854 23         29 $d =~ s/[+]/ /g; ###! _ to [+]
855 23         31 $d =~ s/'//g;
856             }
857 19 100       40 $h->{'query'}{$_->fld} = (@d == 1) ? $d[0] : [@d];
858             }
859 9 100       21 $h->{'annot'} = [@an] if @an;
860 9         12 push @dbq, $h;
861             }
862 6         52 return @dbq;
863             }
864              
865             =head4 QRY _make_q_guts
866              
867             Title : _make_q_guts (Internal class method)
868             Usage : _make_q_guts($ptree, $q_expr, $qarry, $anarry)
869             Function: traverses the parse tree returned from QRY::_parse_q, checking
870             syntax and creating HIVQuery-compliant query structures
871             Example :
872             Returns :
873             Args : $parse_tree (hashref), $query_expression (scalar string ref),
874             $query_array (array ref : stack for returning query structures),
875             $annotation_array (array ref : stack for returning annotation
876             fields)
877              
878             =cut
879              
880             sub _make_q_guts {
881 8     8   11 my ($ptree, $q_expr, $qarry, $anarry) = @_;
882 8         9 my (@words, $o);
883 8         8 eval { # catch
884 8         8 foreach (@{$ptree->{cont}}) {
  8         17  
885 54 100       87 m{^AND$} && do {
886 2         5 $$q_expr .= "&";
887 2         2 next;
888             };
889 52 100       75 m{^OR$} && do {
890 3         5 $$q_expr .= "|";
891 3         3 next;
892             };
893 49 100       91 m{^HASH} && do {
894 33         41 for my $dl ($_->{delim}) {
895 33 100       55 ($dl =~ m{\(}) && do {
896 7 100       6 if (grep /^HASH/, @{$_->{cont}}) {
  7         25  
897 1 50 33     6 $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
      33        
898 1         2 $$q_expr .= "(";
899 1         6 _make_q_guts($_,$q_expr,$qarry,$anarry);
900 1         2 $$q_expr .= ")";
901             }
902             else {
903 6         7 my @c;
904 6         5 my $c = join(' ',@{$_->{cont}});
  6         15  
905 6         13 $c =~ s/,/ /g;
906 6 50       33 Bio::Root::Root->throw("query syntax error: unmatched ['\"]") if (@c = ($c =~ /(['"])/g)) % 2;
907 6         31 @c = split(/\s*(['"])\s*/, $c);
908 6         6 do {
909 16         14 $c = shift @c;
910 16 100       27 if ($c =~ m{['"]}) {
911 6         12 $c = join('', ($c, shift @c, shift @c));
912 6         16 $c =~ s/\s+/+/g; ###! _ to +
913 6         14 push @words, $c;
914             }
915             else {
916 10         30 push @words, split(/\s+/,$c);
917             }
918             } while @c;
919             }
920 7         9 last;
921             };
922 26 100       45 ($dl =~ m{\[}) && do {
923 22 50       17 Bio::Root::Root->throw("syntax error: empty field descriptor") unless @{$_->{cont}};
  22         42  
924 22 50       17 Bio::Root::Root->throw("syntax error: more than one field descriptor in square brackets") unless @{$_->{cont}} == 1;
  22         35  
925              
926 22         17 push @{$qarry}, new QRY( new R( new Q( $_->{cont}->[0], @words)));
  22         59  
927             # add default operation if nec
928 22 100 66     135 $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
      100        
929 22         38 $$q_expr .= "\$q[".$#$qarry."]";
930 22         25 @words = ();
931 22         22 last;
932             };
933 4 50       10 ($dl =~ m{\{}) && do {
934 4         5 foreach my $an (@{$_->{cont}}) {
  4         7  
935 13 100       26 ($an =~ /^HASH/) && do {
936 7 50       10 if ($an->{delim} eq '[') {
937 7         5 push @$anarry, @{$an->{cont}};
  7         9  
938             }
939             else {
940 0         0 Bio::Root::Root->throw("query syntax error: only field descriptors (with or without square brackets) allowed in annotation spec");
941             }
942 7         8 next;
943             };
944 6         6 do { #else
945 6         6 push @$anarry, $an;
946 6         4 next;
947             };
948             }
949 4         5 last;
950             };
951 0         0 do {
952 0         0 1; #else stub
953             };
954             }
955 33         33 next;
956             };
957 16         12 do { # else, bareword
958 16 50       21 if ($o) {
959 0         0 $words[-1] .= "+$_"; ####! _ to +
960             }
961             else {
962 16         18 push @words, $_;
963             }
964 16 100       36 m/['"]/ && ($o = !$o);
965             };
966             } # @{ptree->{cont}}
967 8 50       33 Bio::Root::Root->throw("query syntax error: no search fields specified")
968             unless $$q_expr =~ /q\[[0-9]+\]/;
969             };
970 8 50       21 $@ ?
971             throw Bio::Root::Root(-class=>'Bio::QueryStringSyntax::Exception',
972             -text=>$@,
973             -value=>$$q_expr)
974             : return 1;
975             }
976              
977             =head4 QRY _parse_q
978              
979             Title : _parse_q
980             Usage : QRY::_parse_q($query_string)
981             Function: perform first pass parse of a query string with some syntax
982             checking, return a parse tree suitable for QRY::_make_q
983             Example : QRY::_parse_q(" to[be] OR (not to)[be] ");
984             Returns : hashref
985             Args : query string
986              
987             =cut
988              
989             # parse qry string into a branching tree structure
990             # each branch tagged by the opening delimiter ( key 'delim' )
991             # content (tokens and subbranch hashes) placed in l2r order in
992             # @{p->{cont}}
993             sub _parse_q {
994 6     6   8 local $_;
995 6         5 my $qstr = shift;
996 6         20 my $illegal = qr/[^a-zA-Z0-9-_<>=,\.\(\[\{\}\]\)\s'"]/;
997 6         15 my $pdlm = qr/[\{\[\(\)\]\}]/;
998 6         22 my %md = ('('=>')', '['=>']','{'=>'}');
999 6         138 my @tok = grep !/^\s*$/, split /($pdlm)/, $qstr;
1000 6 50       21 return {} unless @tok;
1001 6         6 my @pstack = ();
1002 6         8 my @dstack = ();
1003 6         7 my ($ptree, $p);
1004              
1005 6         6 eval { #catch
1006 6 50       25 Bio::Root::Root->throw("query syntax error: illegal character") if $qstr =~ /$illegal/;
1007              
1008 6         15 $ptree = $p = {'delim'=>'*'};
1009 6         14 foreach (@tok) {
1010             #trim whsp
1011 107         103 s/^\s+//;
1012 107         89 s/\s+$//;
1013 107 100       146 m{[\(\[\{]} && do {
1014 32         41 my $new = {'delim'=>$_};
1015 32 100       53 $p->{cont} = [] unless $p->{cont};
1016 32         23 push @{$p->{cont}}, $new;
  32         36  
1017 32         24 push @pstack, $p;
1018 32         27 push @dstack, $_;
1019 32         23 $p = $new;
1020 32         30 next;
1021             };
1022 75 100       101 m{[\)\]\}]} && do {
1023 32         30 my $d = pop @dstack;
1024 32 50       49 if ($md{$d} eq $_) {
1025 32         21 $p = pop @pstack;
1026 32 50       49 Bio::Root::Root->throw("query syntax error: unmatched \"$_\"") unless $p;
1027             }
1028             else {
1029 0         0 Bio::Root::Root->throw("query syntax error: saw \"$_\" before matching \"$md{$d}\"");
1030             }
1031 32         29 next;
1032             };
1033 43         31 do { # else
1034 43 100       102 $p->{cont} = [] unless $p->{cont};
1035 43         32 push @{$p->{cont}}, split(/\s+/);
  43         96  
1036             };
1037             }
1038             };
1039 6 50       46 $@ ?
1040             throw Bio::Root::Root(-class=>'Bio::QueryStringSyntax::Exception',
1041             -text=>$@,
1042             -value=>"")
1043             : return $ptree;
1044             }
1045              
1046             ## QRY constructor
1047              
1048             =head3 QRY CONSTRUCTOR
1049              
1050             =head4 QRY Constructor
1051              
1052             Title : QRY constructor
1053             Usage : $QRY = new QRY()
1054             Function:
1055             Example :
1056             Returns :
1057             Args : array of R objects, optional
1058              
1059             =cut
1060              
1061             sub new {
1062 45     45   41 my $class = shift;
1063 45         48 my @args = @_;
1064 45         41 my $self = {};
1065 45         59 $self->{requests} = [];
1066 45         43 bless($self, $class);
1067 45 100       98 $self->put_requests(@args) if @args;
1068 45         104 return $self;
1069             }
1070              
1071             ## QRY instance methods
1072              
1073             =head3 QRY INSTANCE METHODS
1074              
1075             =head4 QRY requests
1076              
1077             Title : requests
1078             Usage : $QRY->requests
1079             Function: get/set array of requests comprising this QRY object
1080             Example :
1081             Returns :
1082             Args : array of class R objects
1083              
1084             =cut
1085              
1086             sub requests {
1087 95     95   68 my $self = shift;
1088 95 50       121 $self->put_requests(@_) if @_;
1089 95         56 return @{$self->{'requests'}};
  95         242  
1090             }
1091              
1092             =head4 QRY put_requests
1093              
1094             Title : put_requests
1095             Usage : $QRY->put_request(@R)
1096             Function: add object of class R to $QRY
1097             Example :
1098             Returns :
1099             Args : [an array of] of class R object[s]
1100              
1101             =cut
1102              
1103             sub put_requests {
1104 42     42   34 my $self = shift;
1105 42         39 my @args = @_;
1106 42         43 foreach (@args) {
1107 46 50 33     196 Bio::Root::Root->throw('requires type R (request)') unless ref && $_->isa('R');
1108 46         33 push @{$self->{requests}}, $_;
  46         96  
1109             }
1110 42         41 return @args;
1111             }
1112              
1113             =head4 QRY isnull
1114              
1115             Title : isnull
1116             Usage : $QRY->isnull
1117             Function: test if QRY object is null
1118             Example :
1119             Returns : 1 if null, 0 otherwise
1120             Args :
1121              
1122             =cut
1123              
1124             sub isnull {
1125 47     47   34 my $self = shift;
1126 47 100       57 return ($self->requests) ? 0 : 1;
1127             }
1128              
1129             =head4 QRY A
1130              
1131             Title : A
1132             Usage : print $QRY->A
1133             Function: get a string representation of QRY object
1134             Example :
1135             Returns : string scalar
1136             Args :
1137              
1138             =cut
1139              
1140             sub A {
1141 0     0   0 my $self = shift;
1142 0         0 return join( "\n", map {$_->A} $self->requests );
  0         0  
1143             }
1144              
1145             =head4 QRY len
1146              
1147             Title : len
1148             Usage : $QRY->len
1149             Function: get number of class R objects contained by QRY object
1150             Example :
1151             Returns : scalar
1152             Args :
1153              
1154             =cut
1155              
1156             sub len {
1157 14     14   13 my $self = shift;
1158 14         9 return scalar @{$self->{'requests'}};
  14         25  
1159             }
1160              
1161             =head4 QRY clone
1162              
1163             Title : clone
1164             Usage : $QRY2 = $QRY1->clone;
1165             Function: create and return a clone of the object
1166             Example :
1167             Returns : object of class QRY
1168             Args :
1169              
1170             =cut
1171              
1172             sub clone {
1173 0     0   0 local $_;
1174 0         0 my $self = shift;
1175 0         0 my $ret = QRY->new();
1176 0         0 foreach ($self->requests) {
1177 0         0 $ret->put_requests($_->clone);
1178             }
1179 0         0 return $ret;
1180             }
1181              
1182             ## QRY class methods
1183              
1184             =head3 QRY CLASS METHODS
1185              
1186             =head4 QRY Or
1187              
1188             Title : Or
1189             Usage : $QRY3 = QRY::Or($QRY1, $QRY2)
1190             Function: logical OR for QRY objects
1191             Example :
1192             Returns : a QRY object
1193             Args : two class QRY objects
1194              
1195             =cut
1196              
1197             sub Or {
1198 4     4   4 local $_;
1199 4         6 my ($q, $r, $rev_f) = @_;
1200 4 50 33     25 Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1201 4 50 33     17 Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1202 4 50       8 if ($q->isnull) {
    50          
1203 0         0 return $r->clone;
1204             }
1205             elsif ($r->isnull) {
1206 0         0 return $q->clone;
1207             }
1208 4 50       10 do {my $qq = $q; $q=$r; $r=$qq} if ($q->len > $r->len);
  0         0  
  0         0  
  0         0  
1209 4         7 my @rq_r = $r->requests;
1210 4         7 my @rq_q = $q->requests;
1211 4         5 my (@cand_rq, @ret_rq);
1212             # search for simplifications
1213 4         5 my @now = @rq_q;
1214 4         4 my @nxt =();
1215 4         5 foreach (@rq_r) {
1216 4         4 my $found = 0;
1217 4         11 while (my $rq = pop @now) {
1218 4         8 my @result = R::Or($rq, $_);
1219 4 100       11 if (@result==1) {
1220 1         2 push @cand_rq, $result[0]->clone;
1221 1         2 $found = 1;
1222 1         3 last;
1223             }
1224             else {
1225 3         15 push @nxt, $rq;
1226             }
1227             }
1228 4 100       12 push @cand_rq, $_->clone unless ($found);
1229             # @now becomes unexamined @rq_q's plus failed @rq_q's
1230 4         7 @now = (@now, @nxt);
1231             }
1232 4         6 push @cand_rq, map {$_->clone} @now; # add all failed @rq_q's
  3         5  
1233             # squeeze out redundant requests
1234 4         11 while (my $rq = pop @cand_rq) {
1235 7 50 66     27 push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq;
  3         6  
1236             }
1237 4         12 return new QRY( @ret_rq );
1238             }
1239              
1240             =head4 QRY And
1241              
1242             Title : And
1243             Usage : $QRY3 = QRY::And($QRY1, $QRY2)
1244             Function: logical AND for QRY objects
1245             Example :
1246             Returns : a QRY object
1247             Args : two class QRY objects
1248              
1249             =cut
1250              
1251             sub And {
1252 14     14   18 my ($q, $r, $rev_f) = @_;
1253 14 50 33     68 Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1254 14 50 33     51 Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1255 14 50 33     22 return ($QRY::NULL) if ($q->isnull || $r->isnull);
1256 14         16 my (@cand_rq, @ret_rq);
1257 14         17 foreach my $rq_r ($r->requests) {
1258 14         15 foreach my $rq_q ($q->requests) {
1259 15         23 my ($rq) = R::And($rq_r, $rq_q);
1260 15 100       19 push @cand_rq, $rq unless $rq->isnull;
1261             }
1262             }
1263 14 100       31 return $QRY::NULL unless @cand_rq;
1264             # squeeze out redundant requests
1265 13         25 while (my $rq = pop @cand_rq) {
1266 14 50 66     40 push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq;
  1         3  
1267             }
1268 13         24 return new QRY( @ret_rq );
1269             }
1270              
1271             =head4 QRY Bool
1272              
1273             Title : Bool
1274             Usage : QRY::Bool($QRY1)
1275             Function: allows symbolic testing of QRY object when bool overloaded
1276             Example : do {stuff} if $QRY1 *same as* do {stuff} if !$QRY1->isnull
1277             Returns :
1278             Args : a class QRY object
1279              
1280             =cut
1281              
1282             sub Bool {
1283 3     3   164 my $q = shift;
1284 3 50 33     37 Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1285 3 50       4 return $q->isnull ? 0 : 1;
1286             }
1287              
1288             =head4 QRY Eq
1289              
1290             Title : Eq
1291             Usage : QRY::Eq($QRY1, $QRY2)
1292             Function: test if R objects in two QRY objects are the same
1293             (irrespective of order)
1294             Example :
1295             Returns : 1 if equal, 0 otherwise
1296             Args : two class QRY objects
1297              
1298             =cut
1299              
1300             sub Eq {
1301 3     3   4 my ($q, $r, $rev_f) = @_;
1302 3 50 33     14 Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1303 3 50 33     11 Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1304 3 50       6 return 0 unless $q->len == $r->len;
1305 3         5 foreach my $rq_q ($q->requests) {
1306 3         3 my $found = 0;
1307 3         3 foreach my $rq_r ($r->requests) {
1308 3 50       4 if (R::Eq($rq_q,$rq_r)) {
1309 3         3 $found = 1;
1310 3         3 last;
1311             }
1312             }
1313 3 50       8 return 0 unless $found;
1314             }
1315 3         9 return 1;
1316             }
1317              
1318             1;
1319              
1320             =head2 Class R - request objects for QRY algebra
1321              
1322             =head3 R SYNOPSIS
1323              
1324             $R = new R( $q1, $q2 );
1325             $R->put_atoms($q3);
1326             $R->del_atoms('coreceptor', 'phenotype');
1327             return $R->clone;
1328             $R1 = new R( new Q('subtype', 'B') );
1329             $R2 = new R( new Q('subtype', 'B C'),
1330             new Q('country', 'US') );
1331             R::Eq( (R::And($R1, $R2))[0],
1332             new R( new Q('subtype', 'B' ),
1333             new Q('country', 'US') )); # returns 1
1334             QRY::Eq( new QRY(R::Or($R1, $R2)), new QRY($R1, $R2) ); # returns 1
1335             R::In( (R::And($R1, $R2))[0], $R1 ); # returns 1
1336              
1337             =head3 R DESCRIPTION
1338              
1339             Class R objects contain a list of atomic queries (class Q
1340             objects). Each class R object represents a single HTTP request to the
1341             LANL DB. When converted to a DB query, the class Q objects contained
1342             by an R object are effectively Ced.
1343              
1344             =cut
1345              
1346             package # hide from PAUSE
1347             R;
1348 2     2   4156 use strict;
  2         3  
  2         2287  
1349             $R::NULL = R->new();
1350              
1351              
1352             ## R constructor
1353              
1354             =head3 R CONSTRUCTOR
1355              
1356             =head4 R constructor
1357              
1358             Title : R constructor
1359             Usage : $R = new R()
1360             Function: create a new R (request) object
1361             Example :
1362             Returns : class R (request) object
1363             Args : optional, array of class Q objects
1364              
1365             =cut
1366              
1367             sub new {
1368 88     88   64 my $class = shift;
1369 88         81 my @args = @_;
1370 88         72 my $self = {};
1371 88         99 $self->{atoms} = {};
1372 88         89 bless($self, $class);
1373 88 100       153 $self->put_atoms(@args) if @args;
1374 88         111 return $self;
1375             }
1376              
1377             ## R instance methods
1378              
1379             =head3 R INSTANCE METHODS
1380              
1381             =head4 R len
1382              
1383             Title : len
1384             Usage : $R->len
1385             Function: get number of class Q objects contained in R object
1386             Example :
1387             Returns : scalar
1388             Args :
1389              
1390             =cut
1391              
1392             sub len {
1393 111     111   72 my $self = shift;
1394 111         73 return scalar @{[keys %{$self->{'atoms'}}]};
  111         63  
  111         372  
1395             }
1396              
1397             =head4 R atoms
1398              
1399             Title : atoms
1400             Usage : $R->atoms( [optional $field])
1401             Function: get array of class Q (atomic query) objects in class R object
1402             Example : $R->atoms(); $R->atoms('coreceptor')
1403             Returns : array of class Q objects (all Qs or those corresponding to $field
1404             if present)
1405             Args : optional, scalar string
1406              
1407             =cut
1408              
1409             sub atoms {
1410 238     238   158 local $_;
1411             # returns an array of atoms
1412             # no arg: all atoms;
1413             # args: atoms with specified fields
1414 238         166 my $self = shift;
1415 238 100       314 my @flds = (@_ ? @_ : keys %{$self->{'atoms'}});
  82         138  
1416 238 100       398 return wantarray ? map { $self->{'atoms'}->{$_} } @flds : $self->{'atoms'}->{$flds[0]};
  136         210  
1417             }
1418              
1419             =head4 R fields
1420              
1421             Title : fields
1422             Usage : $R->fields
1423             Function: get array of fields of all Q objects contained in $R
1424             Example :
1425             Returns : array of scalars
1426             Args :
1427              
1428             =cut
1429              
1430             sub fields {
1431 79     79   47 my $self = shift;
1432 79         49 return keys %{$self->{'atoms'}};
  79         400  
1433             }
1434              
1435             =head4 R put_atoms
1436              
1437             Title : put_atoms
1438             Usage : $R->put_atoms( @q )
1439             Function: AND an atomic query (class Q object) to the class R object's list
1440             Example :
1441             Returns : void
1442             Args : an [array of] class Q object[s]
1443              
1444             =cut
1445              
1446             sub put_atoms {
1447             # AND this atom to the request
1448 110     110   84 local $_;
1449 110         82 my $self = shift;
1450 110         87 my @args = @_;
1451 110         96 foreach (@args) {
1452 130 50 33     461 Bio::Root::Root->throw('requires type Q (atom)') unless ref && $_->isa('Q');
1453 130 50       133 if ($self->atoms($_->fld)) {
1454 0         0 my $a = Q::qand( $self->atoms($_->fld), $_ );
1455 0 0       0 if ($a->isnull) {
1456 0         0 delete $self->{'atoms'}->{$_->fld};
1457             }
1458             else {
1459 0         0 $self->{atoms}->{$_->fld} = $a->clone;
1460             }
1461             }
1462             else {
1463 130         130 $self->{atoms}->{$_->fld} = $_->clone;
1464             }
1465             }
1466 110         149 return;
1467             }
1468              
1469             =head4 R del_atoms
1470              
1471             Title : del_atoms
1472             Usage : $R->del_atoms( @qfields )
1473             Function: removes class Q objects from R object's list according to the
1474             field names given in arguments
1475             Example :
1476             Returns : the class Q objects deleted
1477             Args : scalar array of field names
1478              
1479             =cut
1480              
1481             sub del_atoms {
1482             # remove atoms by field from request
1483 30     30   27 local $_;
1484 30         18 my $self = shift;
1485 30         26 my @args = @_;
1486 30 100       56 return () unless @args;
1487 6         6 my @ret;
1488 6         7 foreach (@args) {
1489 6         8 push @ret, delete $self->{'atoms'}->{$_};
1490             }
1491 6         9 return @ret;
1492             }
1493              
1494             =head4 R isnull
1495              
1496             Title : isnull
1497             Usage : $R->isnull
1498             Function: test if class R object is null
1499             Example :
1500             Returns : 1 if null, 0 otherwise
1501             Args :
1502              
1503             =cut
1504              
1505             sub isnull {
1506 63     63   51 my $self = shift;
1507 63 100       64 return ($self->len) ? 0 : 1;
1508             }
1509              
1510             =head4 R A
1511              
1512             Title : A
1513             Usage : print $R->A
1514             Function: get a string representation of class R object
1515             Example :
1516             Returns : string scalar
1517             Args :
1518              
1519             =cut
1520              
1521             sub A {
1522 0     0   0 my $self = shift;
1523 0         0 my @a = sort {$a->fld cmp $b->fld} $self->atoms;
  0         0  
1524 0         0 return join(" ", map {$_->A} @a);
  0         0  
1525             }
1526              
1527             =head4 R clone
1528              
1529             Title : clone
1530             Usage : $R2 = $R1->clone;
1531             Function: create and return a clone of the object
1532             Example :
1533             Returns : object of class R
1534             Args :
1535              
1536             =cut
1537              
1538             sub clone {
1539 45     45   38 local $_;
1540 45         34 my $self = shift;
1541 45         51 my $ret = R->new();
1542 45         51 foreach ($self->atoms) {
1543 69         88 $ret->put_atoms($_->clone);
1544             }
1545 45         60 return $ret;
1546             }
1547              
1548             ## R class methods
1549              
1550             =head3 R CLASS METHODS
1551              
1552             =head4 R In
1553              
1554             Title : In
1555             Usage : R::In($R1, $R2)
1556             Function: tests whether the query represented by $R1 would return a subset
1557             of items returned by the query represented by $R2
1558             Example : print "R2 gets those and more" if R::In($R1, $R2);
1559             Returns : 1 if R1 is subset of R2, 0 otherwise
1560             Args : two class R objects
1561              
1562             =cut
1563              
1564             sub In {
1565 9     9   7 local $_;
1566 9         12 my ($s, $t) = @_;
1567 9 50 33     43 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1568 9 50 33     37 Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1569 9 50       12 return 1 if ($s->isnull);
1570             # common fields
1571 9         20 my @cf = grep {defined} map {my $f=$_; grep /^$f$/,$s->fields} $t->fields;
  11         21  
  17         15  
  17         20  
1572 9 100       16 return 0 unless @cf==$t->len;
1573 5         11 foreach (@cf) {
1574 5         10 my @sd = split(/\s+/, $s->atoms($_)->dta);
1575 5         12 my @td = split(/\s+/, $t->atoms($_)->dta);
1576 5         10 my @cd = grep {defined} map {my $d=$_; grep /^$d$/, @td} @sd;
  4         6  
  9         6  
  9         69  
1577 5 100       19 return 0 unless @cd==@sd;
1578             }
1579 2         8 return 1;
1580             }
1581              
1582             =head4 R And
1583              
1584             Title : And
1585             Usage : @Rresult = R::And($R1, $R2)
1586             Function: logical AND for R objects
1587             Example :
1588             Returns : an array containing class R objects
1589             Args : two class R objects
1590              
1591             =cut
1592              
1593             sub And {
1594 15     15   10 local $_;
1595 15         17 my ($s, $t) = @_;
1596 15 50 33     54 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1597 15 50 33     54 Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1598 15 50 33     21 return ($R::NULL) if ($s->isnull || $t->isnull);
1599              
1600 15 100       27 do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len );
  1         1  
  1         1  
  1         2  
1601             # $t has at least as many fields defined than $s ($t is more restrictive)
1602              
1603             # common fields
1604 15         26 my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields;
  3         6  
  15         15  
  15         19  
1605 15         26 my $ret = R->new();
1606 15         26 my $v = $t->clone;
1607 15         24 $v->del_atoms(@cf);
1608 15         17 my $u = $s->clone;
1609 15         21 $u->del_atoms(@cf);
1610              
1611             # And the atoms with identical fields
1612              
1613 15         17 foreach (@cf) {
1614 3         5 my ($a) = Q::qand($s->atoms($_), $t->atoms($_));
1615 3 100       7 if ($a->isnull) {
1616 1         4 return $R::NULL;
1617             }
1618             else {
1619 2         4 $ret->put_atoms($a);
1620             }
1621             }
1622             # put the private atoms
1623 14         17 $ret->put_atoms($u->atoms, $v->atoms);
1624 14         49 return ($ret);
1625              
1626             }
1627              
1628             =head4 R Or
1629              
1630             Title : Or
1631             Usage : @Rresult = R::Or($R1, $R2)
1632             Function: logical OR for R objects
1633             Example :
1634             Returns : an array containing class R objects
1635             Args : two class R objects
1636              
1637             =cut
1638              
1639             sub Or {
1640 4     4   5 local $_;
1641 4         5 my ($s, $t) = @_;
1642 4 50 33     21 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1643 4 50 33     17 Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1644 4 50       8 if ($s->isnull) {
    50          
1645 0         0 return $t->clone;
1646             }
1647             elsif ($t->isnull) {
1648 0         0 return $s->clone;
1649             }
1650 4 100       11 return $s->clone if (R::In($t, $s));
1651 3 50       9 return $t->clone if (R::In($s, $t));
1652              
1653             # try simplifying
1654 3 50       6 do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len );
  3         5  
  3         3  
  3         3  
1655             # common fields
1656 3         9 my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields;
  4         9  
  4         4  
  4         8  
1657             #
1658 3 50       6 if ($t->len == @cf) {
1659             # all atoms equal within fields but one? If yes, simplify...
1660 0         0 my @df = grep {!Q::qeq($s->atoms($_), $t->atoms($_))} @cf;
  0         0  
1661 0 0       0 if (@df == 1) {
1662 0         0 my ($a) = Q::qor($s->atoms($df[0]), $t->atoms($df[0]));
1663 0         0 my $ret = $s->clone;
1664 0         0 $ret->del_atoms($df[0]);
1665 0         0 $ret->put_atoms($a);
1666 0         0 return ($ret);
1667             }
1668             }
1669              
1670             # neither request contains the other, and the requests cannot be
1671             # simplified; reflect back (clones of) the input...
1672 3         8 return ($s->clone, $t->clone);
1673              
1674             }
1675              
1676             =head4 R Eq
1677              
1678             Title : Eq
1679             Usage : R::Eq($R1, $R2)
1680             Function: test if class Q objects in two R objects are the same
1681             (irrespective of order)
1682             Example :
1683             Returns : 1 if equal, 0 otherwise
1684             Args : two class R objects
1685              
1686             =cut
1687              
1688             sub Eq {
1689 8     8   11 local $_;
1690 8         7 my ($s, $t) = @_;
1691 8 50 33     34 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1692 8 50 33     31 Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1693 8         16 my @sf = $s->fields;
1694 8         14 my @tf = $t->fields;
1695 8 100       33 return 0 unless @sf==@tf;
1696 4         5 my @cf = grep {defined} map {my $f=$_; grep /^$f$/,@sf} @tf;
  5         6  
  5         2  
  5         42  
1697 4 50       9 return 0 unless @cf==@tf;
1698 4         6 foreach (@cf) {
1699 5 50       7 return 0 unless Q::qeq($s->atoms($_), $t->atoms($_));
1700             }
1701 4         11 return 1;
1702             }
1703             1;
1704              
1705             =head2 Class Q - atomic query objects for QRY algebra
1706              
1707             =head3 Q SYNOPSIS
1708              
1709             $q = new Q('coreceptor', 'CXCR4 CCR5');
1710             $u = new Q('coreceptor', 'CXCR4');
1711             $q->fld; # returns 'coreceptor'
1712             $q->dta; # returns 'CXCR4 CCR5'
1713             print $q->A; # prints '(CXCR4 CCR5)[coreceptor]
1714             Q::qeq($q, $u); # returns 0
1715             Q::qeq( Q::qor($q, $q), $q ); # returns 1
1716             Q::qin($u, $q) # returns 1
1717             Q::qeq(Q::qand($u, $q), $u ); # returns 1
1718              
1719             =head3 Q DESCRIPTION
1720              
1721             Class Q objects represent atomic queries, that can be described by a
1722             single LANL cgi parameter=value pair. Class R objects (requests) are
1723             built from class Qs. The logical operations at the higher levels
1724             (C) ultimately depend on the lower level operations on Qs:
1725             C.
1726              
1727             =cut
1728              
1729             package # hide from PAUSE
1730             Q;
1731 2     2   11 use strict;
  2         1  
  2         2105  
1732             $Q::NULL = Q->new();
1733              
1734             ## Q constructor
1735              
1736             =head3 Q CONSTRUCTOR
1737              
1738             =head4 Q constructor
1739              
1740             Title : Q constructor
1741             Usage : $q = new Q($field, $data)
1742             Function: create a new Q (atomic query) object
1743             Example :
1744             Returns : class Q object
1745             Args : optional $field, $data strings
1746              
1747             =cut
1748              
1749             sub new {
1750 232     232   160 local $_;
1751 232         261 my ($class,@args) = @_;
1752 232         167 my $self={};
1753 232         244 foreach (@args) { s/^\s+//; s/\s+$//; }
  464         441  
  464         463  
1754 232         240 my ($fld, @dta) = @args;
1755 232         244 $self->{fld}=$fld;
1756 232         263 $self->{dta}=join(" ", @dta);
1757 232         175 bless($self, $class);
1758 232         331 return $self;
1759             }
1760              
1761             ## Q instance methods
1762              
1763             =head3 Q INSTANCE METHODS
1764              
1765             =head4 Q isnull
1766              
1767             Title : isnull
1768             Usage : $q->isnull
1769             Function: test if class Q object is null
1770             Example :
1771             Returns : 1 if null, 0 otherwise
1772             Args :
1773              
1774             =cut
1775              
1776             sub isnull {
1777 10     10   6 my $self = shift;
1778 10 50 33     35 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1779 10 50 66     20 return 1 unless (($self->fld && length($self->fld)) || ($self->dta && length($self->dta)));
      33        
      66        
1780 8         18 return 0;
1781             }
1782              
1783             =head4 Q fld
1784              
1785             Title : fld
1786             Usage : $q->fld($field)
1787             Function: get/set fld (field name) property
1788             Example :
1789             Returns : scalar
1790             Args : scalar
1791              
1792             =cut
1793              
1794             sub fld {
1795 515     515   620 my $self = shift;
1796 515 50 33     1435 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1797 515         364 my $f = shift;
1798 515 50       535 if ($f) {
1799 0         0 $f =~ s/^\s+//;
1800 0         0 $f =~ s/\s+$//;
1801 0         0 return $self->{fld}=$f;
1802             }
1803 515         796 return $self->{fld};
1804             }
1805              
1806              
1807             =head4 Q dta
1808              
1809             Title : dta
1810             Usage : $q->dta($data)
1811             Function: get/set dta (whsp-separated data string) property
1812             Example :
1813             Returns : scalar
1814             Args : scalar
1815              
1816             =cut
1817              
1818             sub dta {
1819 249     249   180 my $self = shift;
1820 249 50 33     757 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1821 249         239 my $d = join(" ", @_);
1822 249 50       282 if ($d) {
1823 0         0 $d =~ s/^\s+//;
1824 0         0 $d =~ s/\s+$//;
1825 0         0 return $self->{dta} = $d;
1826             }
1827 249         409 return $self->{dta};
1828             }
1829              
1830             =head4 Q A
1831              
1832             Title : A
1833             Usage : print $q->A
1834             Function: get a string representation of class Q object
1835             Example :
1836             Returns : string scalar
1837             Args :
1838              
1839             =cut
1840              
1841             sub A {
1842 0     0   0 my $self = shift;
1843 0 0 0     0 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1844 0         0 my @a = split(/\s+/, $self->dta);
1845              
1846 0         0 return "(".join(' ', sort {$a cmp $b} @a).")[".$self->fld."]";
  0         0  
1847             }
1848              
1849             =head4 Q clone
1850              
1851             Title : clone
1852             Usage : $q2 = $q1->clone;
1853             Function: create and return a clone of the object
1854             Example :
1855             Returns : object of class Q
1856             Args :
1857              
1858             =cut
1859              
1860             sub clone {
1861 199     199   124 my $self = shift;
1862 199 50 33     639 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1863 199         208 my $ret = Q->new($self->fld, $self->dta);
1864 199         269 return $ret;
1865             }
1866              
1867             ### Q class methods
1868              
1869             =head3 Q CLASS METHODS
1870              
1871             =head4 Q qin
1872              
1873             Title : qin
1874             Usage : Q::qin($q1, $q2)
1875             Function: tests whether the query represented by $q1 would return a subset
1876             of items returned by the query represented by $q2
1877             Example : print "q2 gets those and more" if Q::qin($q1, $q2);
1878             Returns : 1 if q1 is subset of q2, 0 otherwise
1879             Args : two class Q objects
1880              
1881             =cut
1882              
1883             sub qin {
1884 0     0   0 my ($a, $b) = @_;
1885 0 0 0     0 Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
      0        
      0        
1886 0 0       0 return 0 unless $a->fld eq $b->fld;
1887 0         0 return Q::qeq( $b, Q::qor($a, $b) );
1888             }
1889              
1890             =head4 Q qeq
1891              
1892             Title : qeq
1893             Usage : Q::qeq($q1, $q2)
1894             Function: test if fld and dta properties in two class Q objects are the same
1895             (irrespective of order)
1896             Example :
1897             Returns : 1 if equal, 0 otherwise
1898             Args : two class Q objects
1899              
1900             =cut
1901              
1902             sub qeq {
1903 5     5   4 local $_;
1904 5         6 my ($a, $b) = @_;
1905 5 50 33     38 Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
      33        
      33        
1906 5 50       6 return 0 unless $a->fld eq $b->fld;
1907 5         8 my @ad = unique(split(/\s+/,$a->dta));
1908 5         8 my @bd = unique(split(/\s+/,$b->dta));
1909 5 50       11 return 0 unless @ad==@bd;
1910 5         6 my @cd = grep {defined} map {my $f = $_; grep /^$f$/, @ad} @bd;
  13         15  
  13         9  
  13         96  
1911 5         16 return @cd == @bd;
1912             }
1913              
1914             =head4 Q qor
1915              
1916             Title : qor
1917             Usage : @qresult = Q::qor($q1, $q2)
1918             Function: logical OR for Q objects
1919             Example :
1920             Returns : an array of class Q objects
1921             Args : two class Q objects
1922              
1923             =cut
1924              
1925             sub qor {
1926 0     0   0 local $_;
1927 0         0 my @a = @_;
1928 0         0 foreach (@a) {
1929 0 0 0     0 Bio::Root::Root->throw("requires type Q (atom)") unless ref && $_->isa('Q');
1930             }
1931 0         0 my @ret;
1932 0         0 my (%f, @f);
1933 0         0 @a = grep {!$_->isnull} @a;
  0         0  
1934 0 0       0 return ($Q::NULL) unless @a > 0;
1935             # list of unique flds
1936 0         0 @f = unique(map {$_->fld} @a);
  0         0  
1937 0         0 foreach my $f (@f) {
1938 0         0 my @fobjs = grep {$_->fld eq $f} @a;
  0         0  
1939 0         0 my @d = unique(map {split(/\s/, $_->dta)} @fobjs );
  0         0  
1940 0         0 my $r = Q->new($f, @d);
1941 0         0 push @ret, $r;
1942             }
1943 0         0 return @ret;
1944             }
1945              
1946             =head4 Q qand
1947              
1948             Title : qand
1949             Usage : @qresult = Q::And($q1, $q2)
1950             Function: logical AND for R objects
1951             Example :
1952             Returns : an array of class Q objects
1953             Args : two class Q objects
1954              
1955             =cut
1956              
1957             sub qand {
1958 3     3   3 local $_;
1959 3         3 my ($a, $b) = @_;
1960 3 50 33     25 Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
      33        
      33        
1961 3         3 my @ret;
1962 3 50       7 if (ref $a eq 'ARRAY') {
    50          
1963 0         0 foreach my $ea (@$a) {
1964 0         0 push @ret, qand( $ea, $b );
1965             }
1966 0         0 return qor(@ret); # simplify
1967             }
1968             elsif (ref $b eq 'ARRAY') {
1969 0         0 foreach my $eb (@$b) {
1970 0         0 push @ret, qand( $a, $eb);
1971 0         0 1;
1972             }
1973 0         0 return qor(@ret); # simplify
1974             }
1975             else {
1976 3 50 33     5 return ($Q::NULL) if ($a->isnull || $b->isnull);
1977 3 50       4 if ($a->fld eq $b->fld) {
1978             # find intersection of data
1979 3         2 my (%ad, @ad, @bd);
1980 3         6 @ad = split(/\s+/, $a->dta);
1981 3         9 @ad{@ad} = (1) x @ad;
1982 3         14 @bd = split(/\s+/, $b->dta);
1983 3         4 foreach (@bd) {
1984 6         7 $ad{$_}++;
1985             }
1986             my $r = Q->new($a->fld,
1987 9         10 grep {$_}
1988 3 100       5 map {$ad{$_} == 2 ? $_ : undef} keys %ad);
  9         15  
1989 3 100       6 return (length($r->dta) > 0) ? ($r) : ($Q::NULL);
1990             }
1991             else {
1992 0         0 return ($a, $b);
1993             }
1994             }
1995             }
1996              
1997             =head3 Q INTERNALS
1998              
1999             =head4 Q unique
2000              
2001             Title : unique
2002             Usage : @ua = unique(@a)
2003             Function: return contents of @a with duplicates removed
2004             Example :
2005             Returns :
2006             Args : an array
2007              
2008             =cut
2009              
2010             sub unique {
2011 10     10   13 my @a = @_;
2012 10         7 my %a;
2013 10         16 @a{@a} = undef;
2014 10         22 return keys %a;
2015             }
2016              
2017             1;
2018              
2019             =head2 Additional tools for Bio::AnnotationCollectionI
2020              
2021             =head3 Bio::AnnotationCollectionI SYNOPSIS (additional methods)
2022              
2023             $seq->annotation->put_value('patient_id', 1401)
2024             $seq->annotation->get_value('patient_ids') # returns 1401
2025             $seq->annotation->put_value('patient_group', 'MassGenH')
2026             $seq->annotation->put_value(['clinical', 'cd4count'], 503);
2027             $seq->annotation->put_value(['clinical', 'virus_load'], 150805);
2028             foreach ( qw( cd4count virus_load ) ) {
2029             $blood_readings{$_} = $seq->annonation->get_value(['clinical', $_]);
2030             }
2031              
2032             =head3 Bio::AnnotationCollectionI DESCRIPTION (additional methods)
2033              
2034             C and C allow easy creation of and access to an
2035             annotation collection tree with nodes of L. These
2036             methods obiviate direct accession of the SimpleValue objects.
2037              
2038             =cut
2039              
2040             package Bio::AnnotationCollectionI;
2041 2     2   10 use strict;
  2         2  
  2         39  
2042 2     2   565 use Bio::Annotation::SimpleValue;
  2         2  
  2         651  
2043              
2044             =head2 get_value
2045              
2046             Title : get_value
2047             Usage : $ac->get_value($tagname) -or-
2048             $ac->get_value( $tag_level1, $tag_level2,... )
2049             Function: access the annotation value assocated with the given tags
2050             Example :
2051             Returns : a scalar
2052             Args : an array of tagnames that descend into the annotation tree
2053              
2054             =cut
2055              
2056             sub get_value {
2057 0     0 0   local $_;
2058 0           my $self = shift;
2059 0           my @args = @_;
2060 0           my @h;
2061 0 0         return "" unless @_;
2062 0           while ($_ = shift @args) {
2063 0           @h = $self->get_Annotations($_);
2064 0 0         if (ref($h[0]->{value})) {
2065 0           $self = $h[0]->{value}; # must be another Bio::AnnotationCollectionI
2066             }
2067             else {
2068 0           last;
2069             }
2070             }
2071 0   0       return $h[0] && $h[0]->{value} ; # now the last value.
2072             }
2073              
2074             =head2 put_value
2075              
2076             Title : put_value
2077             Usage : $ac->put_value($tagname, $value) -or-
2078             $ac->put_value([$tag_level1, $tag_level2, ...], $value) -or-
2079             $ac->put_value( [$tag_level1, $tag_level2, ...] )
2080             Function: create a node in an annotation tree, and assign a scalar value to it
2081             if a value is specified
2082             Example :
2083             Returns : scalar or a Bio::AnnotationCollection object
2084             Args : $tagname, $value scalars (can be specified as -KEYS=>$tagname,
2085             -VALUE=>$value) -or-
2086             \@tagnames, $value (or as -KEYS=>\@tagnames, -VALUE=>$value )
2087             Note : If intervening nodes do not exist, put_value creates them, replacing
2088             existing nodes. So if $ac->put_value('x', 10) was done, then later,
2089             $ac->put_value(['x', 'y'], 20), the original value of 'x' is trashed,
2090             and $ac->get_value('x') will now return the annotation collection
2091             with tagname 'y'.
2092              
2093             =cut
2094              
2095             sub put_value {
2096 0     0 0   local $_;
2097 0           my $self = shift;
2098 0           my @args = @_;
2099 0           my ($keys, $value) = $self->_rearrange([qw( KEYS VALUE )], @args);
2100 0           my (@keys, $lastkey);
2101             # $value ||= new Bio::Annotation::Collection;
2102 0 0         @keys = (ref($keys) eq 'ARRAY') ? @$keys : ($keys);
2103 0           $lastkey = pop @keys;
2104 0           foreach (@keys) {
2105 0           my $a = $self->get_value($_);
2106 0 0 0       if (ref($a) && $a->isa('Bio::Annotation::Collection')) {
2107 0           $self = $a;
2108             }
2109             else {
2110             # replace an old value
2111 0 0         $self->remove_Annotations($_) if $a;
2112 0           my $ac = Bio::Annotation::Collection->new();
2113 0           $self->add_Annotation(Bio::Annotation::SimpleValue->new(
2114             -tagname => $_,
2115             -value => $ac
2116             )
2117             );
2118 0           $self = $ac;
2119             }
2120             }
2121 0 0         if ($self->get_value($lastkey)) {
2122             # replace existing value
2123 0           ($self->get_Annotations($lastkey))[0]->{value} = $value;
2124             }
2125             else {
2126 0           $self->add_Annotation(Bio::Annotation::SimpleValue->new(
2127             -tagname=>$lastkey,
2128             -value=>$value
2129             ));
2130             }
2131 0           return $value;
2132             }
2133              
2134             =head2 get_keys
2135              
2136             Title : get_keys
2137             Usage : $ac->get_keys($tagname_level_1, $tagname_level_2,...)
2138             Function: Get an array of tagnames underneath the named tag nodes
2139             Example : # prints the values of the members of Category 1...
2140             print map { $ac->get_value($_) } $ac->get_keys('Category 1') ;
2141             Returns : array of tagnames or empty list if the arguments represent a leaf
2142             Args : [array of] tagname[s]
2143              
2144             =cut
2145              
2146             sub get_keys {
2147 0     0 0   my $self = shift;
2148 0           my @keys = @_;
2149 0           foreach (@keys) {
2150 0           my $a = $self->get_value($_);
2151 0 0 0       if (ref($a) && $a->isa('Bio::Annotation::Collection')) {
2152 0           $self = $a;
2153             }
2154             else {
2155 0           return ();
2156             }
2157             }
2158 0           return $self->get_all_annotation_keys();
2159             }
2160              
2161             1;