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   637 use strict;
  2         1  
  2         45  
86 2     2   6 use Bio::Root::Root;
  2         2  
  2         59  
87              
88             # globals
89             BEGIN {
90             #exceptions
91 2     2   67 @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   6 use XML::Simple;
  2         2  
  2         9  
130 2     2   123 use Bio::Root::Root;
  2         2  
  2         29  
131 2     2   6 use strict;
  2         2  
  2         3726  
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   143 my $class = shift;
150 3         6 my @args = @_;
151 3         4 my $self = {};
152 3 100       8 if ($args[0]) {
153 2         6 $self->{schema_ref} = loadHIVSchema($args[0]);
154             }
155 3         11 bless($self, $class);
156 3         20 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   197 local $_;
177 265         215 my $self = shift;
178 265         205 my $sref = $self->{schema_ref};
179 265 50       358 Bio::Root::Root->throw("schema not initialized") unless $sref;
180 265         10658 my @k = grep(/\./, keys %$sref);
181 265         1093 my %ret;
182 265         290 foreach (@k) {
183 24380         38265 s/\..*$//;
184 24380         23124 $ret{$_}++;
185             }
186 265         2675 @k = sort keys %ret;
187 265         4570 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   255 my $self = shift;
236 242         240 my $sref = $self->{schema_ref};
237 242 50       350 Bio::Root::Root->throw("schema not initialized") unless $sref;
238 242         189 my @k = sort keys %{$sref};
  242         12153  
239 242         24877 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   65 my $self = shift;
257 74         56 my ($sfield) = @_;
258 74         62 my $sref = $self->{schema_ref};
259 74 50       119 Bio::Root::Root->throw("schema not initialized") unless $sref;
260 74 100       164 return $$sref{$sfield}{option} ? @{$$sref{$sfield}{option}} : ();
  32         242  
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   812 my $self = shift;
277 1232         848 my ($sfield) = @_;
278 1232         844 my $sref = $self->{schema_ref};
279 1232         713 my @ret;
280 1232 50       1386 Bio::Root::Root->throw("schema not initialized") unless $sref;
281 1232 100       1116 if ($sfield) {
282 1223 100       1837 return $$sref{$sfield}{alias} ? @{$$sref{$sfield}{alias}} : ();
  1103         4368  
283             }
284             else { # all valid aliases
285 9 100       12 map {push @ret, @{$$sref{$_}{alias}} if $$sref{$_}{alias}} $self->fields;
  873         1384  
  783         1630  
286 9         244 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   1 my $self = shift;
307 1         2 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         3 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   8 my $self = shift;
333 6         12 my @sfields = @_;
334 6 50       15 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
335 6         4 my ($squish,@ret, %ret);
336 6 100       14 if ($sfields[0] eq '-s') {
337             # squish : remove duplicates from the returned array
338 5         6 $squish=1;
339 5         5 shift @sfields;
340             }
341 6         141 foreach (@sfields) {
342 32         80 push @ret, /^(.*)\./;
343             }
344 6 100       12 if ($squish) {
345             # arg order is clobbered
346 5         16 @ret{@ret} = undef;
347 5         12 @ret = keys %ret;
348             }
349 6 100       31 return (wantarray ? @ret : $ret[0]);
350             }
351              
352             sub tbl {
353             # tablepart alias
354 5     5   12 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   80 my $self = shift;
402 91         98 my @tbl = @_;
403 91         64 my @ret;
404 91 50       163 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
405 91         112 foreach my $tbl (@tbl) {
406             # trim column name
407 101         120 $tbl =~ s/\..*$//;
408 101 50       137 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       246 return (wantarray ? @ret : $ret[0]);
413             }
414              
415             sub pk {
416             # primarykey alias
417 20     20   37 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   88 my $self = shift;
439 87         91 my ($intbl, $totbl) = @_;
440 87 50       144 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
441             # trim col names
442 87         101 $intbl =~ s/\..*$//;
443 87 100       242 $totbl =~ s/\..*$// if $totbl;
444             # check if in-table exists
445 87 50       134 return () unless grep( /^$intbl/i, $self->tables);
446 87         203 my @ret = grep( /$intbl\.(?:[0-9a-zA-Z]+_){2,}id/i, $self->fields);
447 87 100       473 if ($totbl) {
448 70         120 my $tpk = $self->primarykey($totbl);
449 70 0 33     100 return (wantarray ? () : "") unless grep( /^$totbl/i, $self->tables) && $tpk;
    50          
450 70         222 ($tpk) = ($tpk =~ /\.(.*)$/);
451 70         172 @ret = grep( /$tpk$/, @ret);
452 70 50       309 return (wantarray ? @ret : $ret[0]);
453             }
454             else {
455             # return all foreign keys in in-table
456 17         43 return @ret;
457             }
458             }
459              
460             sub fk {
461             # foreignkey alias
462 85     85   126 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   14 my $self = shift;
479 21         28 my @fk = @_;
480 21         14 my @ret;
481 21 50       39 Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref};
482 21         28 foreach (@fk) {
483 21         84 my ($mnem, $fmnem) = /\.([0-9a-zA-Z]+)_([0-9a-zA-Z]+)_.*$/;
484 21 50 33     86 next unless $mnem && $fmnem;
485             # lookup based on Table.Column format of fields
486 21         55 my $sf = [grep( /^[0-9a-zA-Z]+\.$fmnem\_/, $self->fields )]->[0];
487 21 50       190 next unless $sf;
488 21         59 ($sf) = ($sf =~ /^([0-9a-zA-Z]+)\./);
489 21         40 push @ret, $sf;
490             }
491 21 100       70 return (wantarray ? @ret : $ret[0]);
492             }
493              
494             sub ftbl {
495             # foreigntable alias
496 20     20   39 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   13 my $self = shift;
514 15         12 my ($tgt, $tbl) = @_;
515 15         23 my ($stack, $revstack, $found, $revcut) = ([],[], 0, 4);
516 15         22 $self->_find_join_guts($tgt, $tbl, $stack, \$found);
517 15 100       25 if ($found) {
518 10 50       16 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         33 return @$stack;
525             }
526             else {
527 5         9 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   17 my $self = shift;
552 20         21 my ($tbl, $tgt, $stack, $found, $rev) = @_;
553 20 100       35 return () if $tbl eq $tgt;
554 15         20 my $k = $self->pk($tbl);
555 15 100       27 if ($k) {
556             # all fks pointing to pk
557             my @fk2pk = map {
558 5 100       13 $self->fk($_, $k) || ()
  70 50       117  
559             } ($rev ? reverse $self->tables : $self->tables);
560             # skip keys already on stack
561 5 50       36 if (@$stack) {
562 5 50       9 (@$stack == 1) && do {
563 5         36 @fk2pk = grep (!/$$stack[0]/, @fk2pk);
564             };
565 5 50       12 (@$stack > 1 ) && do {
566 0 0       0 @fk2pk = map { my $f=$_; grep(/$f/, @$stack) ? () : $f } @fk2pk;
  0         0  
  0         0  
567             };
568             }
569 5         10 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       45 my @fks = ($rev ? reverse $self->fk($tbl) : $self->fk($tbl));
585             #skip keys already on stack
586 15 100       33 if (@$stack) {
587 5 50       11 (@$stack == 1) && do {
588 5         7 @fks = grep(!/$$stack[0]/, @fks);
589             };
590 5 50       10 (@$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         15 for my $f (@fks) {
597 15         18 push @$stack, $f;
598 15 100       28 if ($self->ftbl($f) eq $tgt) { #found it
599 10         11 $$found = 1;
600 10         19 return;
601             }
602             else {
603 5         9 $self->_find_join_guts($self->ftbl($f), $tgt, $stack, $found, $rev);
604 5 50       14 $$found ? return : pop @$stack;
605             }
606             }
607             }
608             else {
609 5         5 pop @$stack;
610 5         9 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   2 my $fn = shift;
638 2 50       32 Bio::Root::Root->throw("loadHIVSchema: schema file not found") unless -e $fn;
639 2         14 my $q = XML::Simple->new(ContentKey=>'name',NormalizeSpace=>2,ForceArray=>1);
640 2         133 my %ret;
641 2         7 my $ref = $q->XMLin($fn);
642 2         2360902 my @sf = keys %{$$ref{sfield}};
  2         490  
643 2         11 foreach (@sf) {
644 194         208 my $h = $$ref{sfield}{$_};
645 194         221 $ret{$_} = $h;
646 194         198 foreach my $ptr ($$h{option}, $$h{alias}) {
647 388 100       477 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       332 if (ref($ptr) eq 'HASH') {
    50          
652 66         42 my @k = keys %{$ptr};
  66         804  
653 66 50       87 if (grep /desc/, keys %{$ptr->{$k[0]}}) {
  66         229  
654             # slurp the desc's
655 66         63 $$h{desc} = [ map { $$ptr{$_}->{desc} } @k ];
  2426         2737  
656             }
657             # now overwrite with keys (descs in same order...)
658 66         947 $ptr = [@k];
659             }
660             elsif (ref($ptr) eq 'ARRAY') {
661 180 100       107 $ptr = [map { ref eq 'HASH' ? $_->{name} : $_ } @{$ptr}]
  408         659  
  180         171  
662             }
663             else {
664 0         0 1; # stub : doh!
665             }
666             }
667             }
668 194         188 for my $ptr ($$h{ankey}) {
669             # flatten
670 194         111 my $ank = [keys %{$ptr}]->[0];
  194         330  
671 194 100       227 if (!defined $ank) {
672 18         25 delete $$h{ankey};
673             }
674             else {
675 176         211 $h->{antype} = $ptr->{$ank}{antype};
676 176         281 $ptr = $ank;
677             }
678             }
679             }
680 2         58 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   10 my $self = shift;
704 15         14 my ($sfield) = @_;
705 15         15 return ${$self->{schema_ref}}{$sfield};
  15         33  
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   10 use strict;
  2         2  
  2         105  
798             $QRY::NULL = new QRY();
799              
800              
801             use overload
802 2         19 "|" => \&Or,
803             "&" => \&And,
804             "bool" => \&Bool,
805 2     2   6 "==" => \&Eq;
  2         2  
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   10 my $ptree = shift;
842 7         6 my ($q_expr, @q, @an, $query, @dbq);
843 7         15 _make_q_guts($ptree, \$q_expr, \@q, \@an);
844 7         396 $query = eval $q_expr;
845 7 50       38 throw Bio::Root::Root(-class=>'Bio::Root::Exception',
846             -text=>$@,
847             -value=>$q_expr) if $@;
848 7 100       13 return {} if $query->isnull;
849 6         13 foreach my $rq ($query->requests) {
850 9         15 my $h = {'query'=>{}};
851 9         13 foreach ($rq->atoms) {
852 19         25 my @d = split(/\s+/, $_->dta);
853 19         23 foreach my $d (@d) {
854 23         25 $d =~ s/[+]/ /g; ###! _ to [+]
855 23         31 $d =~ s/'//g;
856             }
857 19 100       41 $h->{'query'}{$_->fld} = (@d == 1) ? $d[0] : [@d];
858             }
859 9 100       22 $h->{'annot'} = [@an] if @an;
860 9         14 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         8 my (@words, $o);
883 8         8 eval { # catch
884 8         9 foreach (@{$ptree->{cont}}) {
  8         14  
885 54 100       98 m{^AND$} && do {
886 2         4 $$q_expr .= "&";
887 2         3 next;
888             };
889 52 100       72 m{^OR$} && do {
890 3         4 $$q_expr .= "|";
891 3         3 next;
892             };
893 49 100       87 m{^HASH} && do {
894 33         43 for my $dl ($_->{delim}) {
895 33 100       53 ($dl =~ m{\(}) && do {
896 7 100       4 if (grep /^HASH/, @{$_->{cont}}) {
  7         27  
897 1 50 33     6 $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
      33        
898 1         3 $$q_expr .= "(";
899 1         5 _make_q_guts($_,$q_expr,$qarry,$anarry);
900 1         2 $$q_expr .= ")";
901             }
902             else {
903 6         8 my @c;
904 6         5 my $c = join(' ',@{$_->{cont}});
  6         15  
905 6         12 $c =~ s/,/ /g;
906 6 50       31 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         15 $c = shift @c;
910 16 100       26 if ($c =~ m{['"]}) {
911 6         12 $c = join('', ($c, shift @c, shift @c));
912 6         14 $c =~ s/\s+/+/g; ###! _ to +
913 6         13 push @words, $c;
914             }
915             else {
916 10         24 push @words, split(/\s+/,$c);
917             }
918             } while @c;
919             }
920 7         9 last;
921             };
922 26 100       40 ($dl =~ m{\[}) && do {
923 22 50       17 Bio::Root::Root->throw("syntax error: empty field descriptor") unless @{$_->{cont}};
  22         39  
924 22 50       17 Bio::Root::Root->throw("syntax error: more than one field descriptor in square brackets") unless @{$_->{cont}} == 1;
  22         36  
925              
926 22         17 push @{$qarry}, new QRY( new R( new Q( $_->{cont}->[0], @words)));
  22         58  
927             # add default operation if nec
928 22 100 66     134 $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
      100        
929 22         36 $$q_expr .= "\$q[".$#$qarry."]";
930 22         29 @words = ();
931 22         20 last;
932             };
933 4 50       12 ($dl =~ m{\{}) && do {
934 4         5 foreach my $an (@{$_->{cont}}) {
  4         9  
935 13 100       21 ($an =~ /^HASH/) && do {
936 7 50       12 if ($an->{delim} eq '[') {
937 7         6 push @$anarry, @{$an->{cont}};
  7         11  
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         5 do { #else
945 6         4 push @$anarry, $an;
946 6         6 next;
947             };
948             }
949 4         5 last;
950             };
951 0         0 do {
952 0         0 1; #else stub
953             };
954             }
955 33         29 next;
956             };
957 16         16 do { # else, bareword
958 16 50       20 if ($o) {
959 0         0 $words[-1] .= "+$_"; ####! _ to +
960             }
961             else {
962 16         17 push @words, $_;
963             }
964 16 100       31 m/['"]/ && ($o = !$o);
965             };
966             } # @{ptree->{cont}}
967 8 50       34 Bio::Root::Root->throw("query syntax error: no search fields specified")
968             unless $$q_expr =~ /q\[[0-9]+\]/;
969             };
970 8 50       14 $@ ?
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   7 local $_;
995 6         9 my $qstr = shift;
996 6         18 my $illegal = qr/[^a-zA-Z0-9-_<>=,\.\(\[\{\}\]\)\s'"]/;
997 6         10 my $pdlm = qr/[\{\[\(\)\]\}]/;
998 6         21 my %md = ('('=>')', '['=>']','{'=>'}');
999 6         137 my @tok = grep !/^\s*$/, split /($pdlm)/, $qstr;
1000 6 50       21 return {} unless @tok;
1001 6         8 my @pstack = ();
1002 6         7 my @dstack = ();
1003 6         5 my ($ptree, $p);
1004              
1005 6         8 eval { #catch
1006 6 50       24 Bio::Root::Root->throw("query syntax error: illegal character") if $qstr =~ /$illegal/;
1007              
1008 6         13 $ptree = $p = {'delim'=>'*'};
1009 6         11 foreach (@tok) {
1010             #trim whsp
1011 107         108 s/^\s+//;
1012 107         86 s/\s+$//;
1013 107 100       147 m{[\(\[\{]} && do {
1014 32         39 my $new = {'delim'=>$_};
1015 32 100       47 $p->{cont} = [] unless $p->{cont};
1016 32         24 push @{$p->{cont}}, $new;
  32         36  
1017 32         24 push @pstack, $p;
1018 32         26 push @dstack, $_;
1019 32         22 $p = $new;
1020 32         28 next;
1021             };
1022 75 100       99 m{[\)\]\}]} && do {
1023 32         26 my $d = pop @dstack;
1024 32 50       43 if ($md{$d} eq $_) {
1025 32         24 $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         24 next;
1032             };
1033 43         33 do { # else
1034 43 100       65 $p->{cont} = [] unless $p->{cont};
1035 43         35 push @{$p->{cont}}, split(/\s+/);
  43         85  
1036             };
1037             }
1038             };
1039 6 50       41 $@ ?
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   46 my $class = shift;
1063 45         45 my @args = @_;
1064 45         37 my $self = {};
1065 45         58 $self->{requests} = [];
1066 45         43 bless($self, $class);
1067 45 100       95 $self->put_requests(@args) if @args;
1068 45         110 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   74 my $self = shift;
1088 95 50       129 $self->put_requests(@_) if @_;
1089 95         58 return @{$self->{'requests'}};
  95         253  
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   32 my $self = shift;
1105 42         40 my @args = @_;
1106 42         66 foreach (@args) {
1107 46 50 33     172 Bio::Root::Root->throw('requires type R (request)') unless ref && $_->isa('R');
1108 46         32 push @{$self->{requests}}, $_;
  46         99  
1109             }
1110 42         44 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   40 my $self = shift;
1126 47 100       55 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   12 my $self = shift;
1158 14         11 return scalar @{$self->{'requests'}};
  14         32  
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   6 local $_;
1199 4         4 my ($q, $r, $rev_f) = @_;
1200 4 50 33     26 Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1201 4 50 33     20 Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1202 4 50       7 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         8 my @rq_r = $r->requests;
1210 4         6 my @rq_q = $q->requests;
1211 4         3 my (@cand_rq, @ret_rq);
1212             # search for simplifications
1213 4         6 my @now = @rq_q;
1214 4         6 my @nxt =();
1215 4         8 foreach (@rq_r) {
1216 4         5 my $found = 0;
1217 4         9 while (my $rq = pop @now) {
1218 4         8 my @result = R::Or($rq, $_);
1219 4 100       7 if (@result==1) {
1220 1         3 push @cand_rq, $result[0]->clone;
1221 1         2 $found = 1;
1222 1         2 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         8 @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         12 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         8  
1236             }
1237 4         8 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   19 my ($q, $r, $rev_f) = @_;
1253 14 50 33     69 Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1254 14 50 33     50 Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1255 14 50 33     19 return ($QRY::NULL) if ($q->isnull || $r->isnull);
1256 14         12 my (@cand_rq, @ret_rq);
1257 14         16 foreach my $rq_r ($r->requests) {
1258 14         16 foreach my $rq_q ($q->requests) {
1259 15         20 my ($rq) = R::And($rq_r, $rq_q);
1260 15 100       26 push @cand_rq, $rq unless $rq->isnull;
1261             }
1262             }
1263 14 100       32 return $QRY::NULL unless @cand_rq;
1264             # squeeze out redundant requests
1265 13         27 while (my $rq = pop @cand_rq) {
1266 14 50 66     41 push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq;
  1         3  
1267             }
1268 13         22 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   171 my $q = shift;
1284 3 50 33     17 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     13 Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1304 3 50       5 return 0 unless $q->len == $r->len;
1305 3         5 foreach my $rq_q ($q->requests) {
1306 3         2 my $found = 0;
1307 3         5 foreach my $rq_r ($r->requests) {
1308 3 50       5 if (R::Eq($rq_q,$rq_r)) {
1309 3         3 $found = 1;
1310 3         4 last;
1311             }
1312             }
1313 3 50       7 return 0 unless $found;
1314             }
1315 3         11 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   3850 use strict;
  2         3  
  2         2234  
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   63 my $class = shift;
1369 88         84 my @args = @_;
1370 88         73 my $self = {};
1371 88         98 $self->{atoms} = {};
1372 88         63 bless($self, $class);
1373 88 100       154 $self->put_atoms(@args) if @args;
1374 88         122 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         72 return scalar @{[keys %{$self->{'atoms'}}]};
  111         71  
  111         383  
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   148 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       309 my @flds = (@_ ? @_ : keys %{$self->{'atoms'}});
  82         157  
1416 238 100       397 return wantarray ? map { $self->{'atoms'}->{$_} } @flds : $self->{'atoms'}->{$flds[0]};
  136         218  
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   52 my $self = shift;
1432 79         47 return keys %{$self->{'atoms'}};
  79         421  
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   80 local $_;
1449 110         80 my $self = shift;
1450 110         91 my @args = @_;
1451 110         126 foreach (@args) {
1452 130 50 33     486 Bio::Root::Root->throw('requires type Q (atom)') unless ref && $_->isa('Q');
1453 130 50       138 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         154 $self->{atoms}->{$_->fld} = $_->clone;
1464             }
1465             }
1466 110         165 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   22 local $_;
1484 30         20 my $self = shift;
1485 30         30 my @args = @_;
1486 30 100       53 return () unless @args;
1487 6         3 my @ret;
1488 6         6 foreach (@args) {
1489 6         10 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   42 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   34 local $_;
1540 45         32 my $self = shift;
1541 45         58 my $ret = R->new();
1542 45         57 foreach ($self->atoms) {
1543 69         83 $ret->put_atoms($_->clone);
1544             }
1545 45         58 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   12 local $_;
1566 9         8 my ($s, $t) = @_;
1567 9 50 33     42 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1568 9 50 33     33 Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1569 9 50       11 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         19  
  17         11  
  17         20  
1572 9 100       17 return 0 unless @cf==$t->len;
1573 5         11 foreach (@cf) {
1574 5         9 my @sd = split(/\s+/, $s->atoms($_)->dta);
1575 5         13 my @td = split(/\s+/, $t->atoms($_)->dta);
1576 5         10 my @cd = grep {defined} map {my $d=$_; grep /^$d$/, @td} @sd;
  4         6  
  9         8  
  9         72  
1577 5 100       17 return 0 unless @cd==@sd;
1578             }
1579 2         7 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   13 local $_;
1595 15         15 my ($s, $t) = @_;
1596 15 50 33     57 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     20 return ($R::NULL) if ($s->isnull || $t->isnull);
1599              
1600 15 100       28 do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len );
  1         1  
  1         2  
  1         1  
1601             # $t has at least as many fields defined than $s ($t is more restrictive)
1602              
1603             # common fields
1604 15         32 my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields;
  3         7  
  15         14  
  15         17  
1605 15         26 my $ret = R->new();
1606 15         23 my $v = $t->clone;
1607 15         22 $v->del_atoms(@cf);
1608 15         18 my $u = $s->clone;
1609 15         19 $u->del_atoms(@cf);
1610              
1611             # And the atoms with identical fields
1612              
1613 15         20 foreach (@cf) {
1614 3         6 my ($a) = Q::qand($s->atoms($_), $t->atoms($_));
1615 3 100       5 if ($a->isnull) {
1616 1         4 return $R::NULL;
1617             }
1618             else {
1619 2         3 $ret->put_atoms($a);
1620             }
1621             }
1622             # put the private atoms
1623 14         16 $ret->put_atoms($u->atoms, $v->atoms);
1624 14         70 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   4 local $_;
1641 4         5 my ($s, $t) = @_;
1642 4 50 33     24 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1643 4 50 33     21 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       8 return $s->clone if (R::In($t, $s));
1651 3 50       7 return $t->clone if (R::In($s, $t));
1652              
1653             # try simplifying
1654 3 50       7 do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len );
  3         4  
  3         4  
  3         3  
1655             # common fields
1656 3         8 my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields;
  4         7  
  4         5  
  4         6  
1657             #
1658 3 50       7 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   6 local $_;
1690 8         9 my ($s, $t) = @_;
1691 8 50 33     32 Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1692 8 50 33     33 Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1693 8         15 my @sf = $s->fields;
1694 8         12 my @tf = $t->fields;
1695 8 100       32 return 0 unless @sf==@tf;
1696 4         5 my @cf = grep {defined} map {my $f=$_; grep /^$f$/,@sf} @tf;
  5         9  
  5         6  
  5         39  
1697 4 50       8 return 0 unless @cf==@tf;
1698 4         6 foreach (@cf) {
1699 5 50       6 return 0 unless Q::qeq($s->atoms($_), $t->atoms($_));
1700             }
1701 4         10 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   10 use strict;
  2         5  
  2         2115  
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   175 local $_;
1751 232         250 my ($class,@args) = @_;
1752 232         177 my $self={};
1753 232         232 foreach (@args) { s/^\s+//; s/\s+$//; }
  464         430  
  464         456  
1754 232         258 my ($fld, @dta) = @args;
1755 232         232 $self->{fld}=$fld;
1756 232         271 $self->{dta}=join(" ", @dta);
1757 232         192 bless($self, $class);
1758 232         368 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   9 my $self = shift;
1778 10 50 33     37 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         19 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   345 my $self = shift;
1796 515 50 33     1450 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1797 515         307 my $f = shift;
1798 515 50       545 if ($f) {
1799 0         0 $f =~ s/^\s+//;
1800 0         0 $f =~ s/\s+$//;
1801 0         0 return $self->{fld}=$f;
1802             }
1803 515         830 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   163 my $self = shift;
1820 249 50 33     734 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1821 249         243 my $d = join(" ", @_);
1822 249 50       290 if ($d) {
1823 0         0 $d =~ s/^\s+//;
1824 0         0 $d =~ s/\s+$//;
1825 0         0 return $self->{dta} = $d;
1826             }
1827 249         405 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   130 my $self = shift;
1862 199 50 33     634 Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1863 199         206 my $ret = Q->new($self->fld, $self->dta);
1864 199         278 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   5 local $_;
1904 5         5 my ($a, $b) = @_;
1905 5 50 33     42 Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
      33        
      33        
1906 5 50       7 return 0 unless $a->fld eq $b->fld;
1907 5         7 my @ad = unique(split(/\s+/,$a->dta));
1908 5         11 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         16  
  13         10  
  13         97  
1911 5         18 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       9 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     4 return ($Q::NULL) if ($a->isnull || $b->isnull);
1977 3 50       5 if ($a->fld eq $b->fld) {
1978             # find intersection of data
1979 3         3 my (%ad, @ad, @bd);
1980 3         5 @ad = split(/\s+/, $a->dta);
1981 3         11 @ad{@ad} = (1) x @ad;
1982 3         14 @bd = split(/\s+/, $b->dta);
1983 3         5 foreach (@bd) {
1984 6         7 $ad{$_}++;
1985             }
1986             my $r = Q->new($a->fld,
1987 9         11 grep {$_}
1988 3 100       4 map {$ad{$_} == 2 ? $_ : undef} keys %ad);
  9         14  
1989 3 100       5 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   14 my @a = @_;
2012 10         7 my %a;
2013 10         17 @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   11 use strict;
  2         2  
  2         34  
2042 2     2   385 use Bio::Annotation::SimpleValue;
  2         3  
  2         627  
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;