1 # $Id: HIVQueryHelper.pm 231 2008-12-11 14:32:00Z maj $
3 # BioPerl module for HIVQueryHelper
5 # Cared for by Mark A. Jensen <maj@fortinbras.us>
7 # Copyright Mark A. Jensen
9 # You may distribute this module under the same terms as perl itself
11 # POD documentation - main docs before the code
15 HIVQueryHelper - Routines and packages used by Bio::DB::HIV and Bio::DB::Query::HIVQuery
19 Used in Bio::DB::Query::HIVQuery. No need to use directly.
23 C<Bio::DB::HIV::HIVQueryHelper> contains a number of packages for use
24 by L<Bio::DB::Query::HIVQuery>. Package C<HIVSchema> parses the
25 C<lanl-schema.xml> file, and allows access to it in the context of the
26 relational database it represents (see APPENDIX for excruciating
27 detail). Packages C<QRY>, C<R>, and C<Q> together create the query
28 string parser that enables NCBI-like queries to be understood by
29 C<Bio::DB::Query::HIVQuery>. They provide objects and operators to
30 perform and simplify logical expressions involving C<AND>, C<OR>, and
31 C<()> and return hash structures that can be handled by
32 C<Bio::DB::Query::HIVQuery> routines.
38 User feedback is an integral part of the evolution of this and other
39 Bioperl modules. Send your comments and suggestions preferably to
40 the Bioperl mailing list. Your participation is much appreciated.
42 bioperl-l@bioperl.org - General discussion
43 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
47 Report bugs to the Bioperl bug tracking system to help us keep track
48 of the bugs and their resolution. Bug reports can be submitted via
51 http://bugzilla.open-bio.org/
53 =head1 AUTHOR - Mark A. Jensen
55 Email maj@fortinbras.us
61 The rest of the documentation details each of the contained packages.
62 Internal methods are usually preceded with a _
66 # Let the code begin...
69 package HIVQueryHelper
;
76 @Bio::QueryStringSyntax
::Exception
::ISA
= qw( Bio::Root::Exception);
81 =head2 HIVSchema - objects/methods to manipulate a version of the LANL HIV DB schema
85 $schema = new HIVSchema( 'lanl-schema.xml' );
86 @tables = $schema->tables;
87 @validFields = $schema->fields;
88 @validAliases = $schema->aliases;
89 @query_aliases_for_coreceptor = $schema->aliases( 'SEQ_SAMple.SSAM_second_receptor' );
90 $pk_for_SequenceEntry = $schema->primarykey('SequenceEntry'); # returns 'SequenceEntry.SE_id'
91 $fk_for_SEQ_SAMple_to_SequenceEntry =
92 $schema->foreignkey('SEQ_SAMple', 'SequenceEntry'); # returns 'SEQ_SAMple.SSAM_SE_id'
94 $table = $schema->tablepart('SEQ_SAMple.SSAM_badseq'); # returns 'SEQ_SAMple'
95 $column = $schema->columnpart('SEQ_SAMple.SSAM_badseq'); # returns 'SSAM_badseq'
99 HIVSchema methods are used in L<Bio::DB::Query::HIVQuery> for table,
100 column, primary/foreign key manipulations based on the observed Los
101 Alamos HIV Sequence Database (LANL DB) naming conventions for their
102 CGI parameters. The schema is contained in an XML file
103 (C<lanl-schema.xml>) which is read into an HIVSchema object, in turn a
104 property of the HIVQuery object. HIVSchema methods are used to build
105 correct cgi queries in a way that attempts to preserve the context of
106 the relational database the query parameters represent.
111 # objects/methods to manipulate a version of the LANL HIV DB schema
124 Usage : $schema = new HIVSchema( "lanl-schema.xml ");
127 Returns : an HIVSchema object
137 $self->{schema_ref
} = loadHIVSchema
($args[0]);
139 bless($self, $class);
145 =head3 INSTANCE METHODS
150 Usage : $schema->tables()
151 Function: get all table names in schema
153 Returns : array of table names
159 # return array of all tables in schema
162 my $sref = $self->{schema_ref
};
163 Bio
::Root
::Root
->throw("schema not initialized") unless $sref;
164 my @k = grep(/\./, keys %$sref);
177 Usage : $schema->columns( [$tablename] );
178 Function: return array of columns for specified table, or all columns in
179 schema, if called w/o args
182 Args : tablename or fieldname string
187 # return array of columns for specified table
188 # all columns in schema, if called w/o args
192 my $sref = $self->{schema_ref
};
193 Bio
::Root
::Root
->throw("schema not initialized") unless $sref;
196 # check if table exists
197 return () unless grep(/^$tbl$/i, $self->tables);
198 my @k = sort keys %$sref;
199 @k = grep (/^$tbl\./i, @k);
209 Usage : $schema->fields();
210 Function: return array of all fields in schema, in format "table.column"
212 Returns : array of all fields
218 # return array of all fields (Table.Column format) in schema
220 my $sref = $self->{schema_ref
};
221 Bio
::Root
::Root
->throw("schema not initialized") unless $sref;
222 my @k = sort keys %{$sref};
229 Usage : $schema->options(@fieldnames)
230 Function: get array of options (i.e., valid match data strings) available
233 Returns : array of match data strings
234 Args : [array of] fieldname string[s] in "table.column" format
239 # return array of options available to specified field
242 my $sref = $self->{schema_ref
};
243 Bio
::Root
::Root
->throw("schema not initialized") unless $sref;
244 return $$sref{$sfield}{option
} ? @
{$$sref{$sfield}{option
}} : ();
250 Usage : $schema->aliases(@fieldnames)
251 Function: get array of aliases to specified field[s]
253 Returns : array of valid query aliases for fields as spec'd in XML file
254 Args : [an array of] fieldname[s] in "table.column" format
259 # return array of aliases to specified field
262 my $sref = $self->{schema_ref
};
264 Bio
::Root
::Root
->throw("schema not initialized") unless $sref;
266 return $$sref{$sfield}{alias
} ? @
{$$sref{$sfield}{alias
}} : ();
268 else { # all valid aliases
269 map {push @ret, @
{$$sref{$_}{alias
}} if $$sref{$_}{alias
}} $self->fields;
276 Title : ankh (annotation key hash)
277 Usage : $schema->ankh(@fieldnames)
278 Function: return a has translating fields to annotation keys for the
280 (Annotation keys are used for parsing the tab-delimited response
281 to Bio::DB::Query::HIVQuery::_do_lanl_request.)
284 Args : [an array of] fieldname[s] in "table.column" format
289 # return hash translating sfields to annotation keys for specified sfield(s)
293 my $sref = $self->{schema_ref
};
294 Bio
::Root
::Root
->throw("schema not initialized") unless $sref;
296 next unless $$sref{$_}{ankey
};
297 $ret{$_} = {'ankey'=>$$sref{$_}{ankey
},'antype'=>$$sref{$_}{antype
}};
304 Title : tablepart (alias: tbl)
305 Usage : $schema->tbl(@fieldnames)
306 Function: return the portion of the fieldname[s] that refer to the
308 Example : $schema->tbl('SequenceEntry.SE_id'); # returns 'SequenceEntry'
309 Returns : table name as string
310 Args : [an array of] fieldname[s] in "table.column" format
315 # return the 'Table' part of the specified field(s)
318 Bio
::Root
::Root
->throw("schema not initialized") unless $self->{schema_ref
};
319 my ($squish,@ret, %ret);
320 if ($sfields[0] eq '-s') {
321 # squish : remove duplicates from the returned array
326 push @ret, /^(.*)\./;
329 # arg order is clobbered
333 return (wantarray ?
@ret : $ret[0]);
338 shift->tablepart(@_);
343 Title : columnpart (alias: col)
344 Usage : $schema->col(@fieldnames)
345 Function: return the portion of the fieldname[s] that refer to the
347 Example : $schema->col('SequenceEntry.SE_id'); # returns 'SE_id'
348 Returns : column name as string
349 Args : [an array of] fieldname[s] in "table.column" format
354 # return the 'Column' part of the specified field(s)
357 Bio
::Root
::Root
->throw("schema not initialized") unless $self->{schema_ref
};
360 push @ret, /\.(.*)$/;
362 return (wantarray ?
@ret : $ret[0]);
367 shift->columnpart(@_);
372 Title : primarykey [alias: pk]
373 Usage : $schema->pk(@tablenames);
374 Function: return the primary key of the specified table[s], as judged by
375 the syntax of the table's[s'] fieldnames
376 Example : $schema->pk('SequenceEntry') # returns 'SequenceEntry.SE_id'
377 Returns : primary key fieldname[s] in "table.column" format, or null if
379 Args : [an array of] table name[s] (fieldnames are ok, table part used)
384 # return the primary key (in Table.Column format) of specified table(s)
388 Bio
::Root
::Root
->throw("schema not initialized") unless $self->{schema_ref
};
389 foreach my $tbl (@tbl) {
392 grep(/^$tbl$/i, $self->tables) ?
393 push(@ret, grep(/\.[0-9a-zA-Z]+_id/, grep(/$tbl/i,$self->fields))) :
396 return (wantarray ?
@ret : $ret[0]);
401 shift->primarykey(@_);
406 Title : foreignkey [alias: fk]
407 Usage : $schema->fk($intable [, $totable])
408 Function: return foreign key fieldname in table $intable referring to
409 table $totable, or all foreign keys in $intable if $totable
411 Example : $schema->fk('AUthor', 'SequenceEntry'); # returns 'AUthor_AU_SE_id'
412 Returns : foreign key fieldname[s] in "table.column" format
413 Args : tablename [, optional foreign table name] (fieldnames are ok,
419 # return foreign key in in-table ($intbl) to to-table ($totbl)
420 # or all foreign keys in in-table if to-table not specified
421 # keys returned in Table.Column format
423 my ($intbl, $totbl) = @_;
424 Bio
::Root
::Root
->throw("schema not initialized") unless $self->{schema_ref
};
427 $totbl =~ s/\..*$// if $totbl;
428 # check if in-table exists
429 return () unless grep( /^$intbl/i, $self->tables);
430 my @ret = grep( /$intbl\.(?:[0-9a-zA-Z]+_){2,}id/i, $self->fields);
432 my $tpk = $self->primarykey($totbl);
433 return (wantarray ?
() : "") unless grep( /^$totbl/i, $self->tables) && $tpk;
434 ($tpk) = ($tpk =~ /\.(.*)$/);
435 @ret = grep( /$tpk$/, @ret);
436 return (wantarray ?
@ret : $ret[0]);
439 # return all foreign keys in in-table
446 shift->foreignkey(@_);
451 Title : foreigntable [alias ftbl]
452 Usage : $schema->ftbl( @foreign_key_fieldnames );
453 Function: return tablename of table that foreign keys points to
454 Example : $schema->ftbl( 'AUthor.AU_SE_id' ); # returns 'SequenceEntry'
456 Args : [an array of] fieldname[s] in "table.column" format
461 # return table name that foreign key(s) point(s) to
465 Bio
::Root
::Root
->throw("schema not initialized") unless $self->{schema_ref
};
467 my ($mnem, $fmnem) = /\.([0-9a-zA-Z]+)_([0-9a-zA-Z]+)_.*$/;
468 next unless $mnem && $fmnem;
469 # lookup based on Table.Column format of fields
470 my $sf = [grep( /^[0-9a-zA-Z]+\.$fmnem\_/, $self->fields )]->[0];
472 ($sf) = ($sf =~ /^([0-9a-zA-Z]+)\./);
475 return (wantarray ?
@ret : $ret[0]);
480 shift->foreigntable(@_);
485 Title : loadHIVSchema [alias: loadSchema]
486 Usage : $schema->loadSchema( $XMLfilename )
487 Function: read (LANL DB) schema spec from XML
488 Example : $schema->loadSchema('lanl-schema.xml');
489 Returns : hashref to schema data
490 Keys are fieldnames in "table.column" format.
491 Each value is a hashref with the following properties:
492 {name} : HIVWEB 'table.column' format fieldname,
493 can be used directly in the cgi query
494 {aliases} : ref to array containing valid aliases/shortcuts for
495 {name}; can be used in routines creating the HTML query
496 {options} : ref to array containing valid matchdata for this field
497 can be used directly in the HTML query
498 {ankey} : contains the annotation key for this field used with
499 Bioperl annotation objects
500 {..attr..}: ..value_of_attr.. for this field (app-specific metadata)
507 # look in @INC for file
510 foreach my $d (@INC) {
511 my $p = Bio
::Root
::IO
->catfile($d, $fn);
512 my $b = Bio
::Root
::IO
->catfile($d, qw(Bio DB HIV), $fn);
520 Bio
::Root
::Root
->throw("loadHIVSchema: schema file not found") unless $dir;
521 print STDERR
"$dir\n";
522 my $q = XML
::Simple
->new(ContentKey
=>'name',NormalizeSpace
=>2,ForceArray
=>1);
524 my $ref = $q->XMLin($dir);
525 my @sf = keys %{$$ref{sfield
}};
527 my $h = $$ref{sfield
}{$_};
529 foreach my $ptr ($$h{option
}, $$h{alias
}) {
531 # kludge for XMLin: appears to convert to arrays, if there
532 # exists a tag without content, but to convert to hashes
533 # with content as key, if all tags possess content
534 if (ref($ptr) eq 'HASH') {
535 $ptr = [keys %{$ptr}];
537 elsif (ref($ptr) eq 'ARRAY') {
538 $ptr = [map { ref eq 'HASH' ?
$_->{name
} : $_ } @
{$ptr}]
545 for my $ptr ($$h{ankey
}) {
547 my $ank = [keys %{$ptr}]->[0];
552 $h->{antype
} = $ptr->{$ank}{antype
};
562 $self->{schema_ref
} = loadHIVSchema
(shift);
570 Usage : $schema->_sfieldh($fieldname)
571 Function: get hashref to the specified field hash
574 Args : fieldname in "table.column" format
579 # return reference to the specified field hash
582 return ${$self->{schema_ref
}}{$sfield};
587 =head2 Class QRY - a query algebra for HIVQuery
593 new Q('coreceptor', 'CXCR4'),
594 new Q('country', 'ZA')
597 QRY::Eq(QRY::And($Q, $Q), $Q); # returns 1
598 QRY::Eq(QRY::Or($Q, $Q), $Q); # returns 1
602 new Q( 'coreceptor', 'CCR5' ),
603 new Q( 'country', 'ZA')
606 (QRY::And($Q, $Q2))->isnull; # returns 1
607 $Q3 = QRY::Or($Q, $Q2);
608 print $Q3->A; # prints '(CCR5 CXCR4)[coreceptor] (ZA)[country]'
612 The QRY package provides a query parser for
613 L<Bio::DB::Query::HIVQuery>. Currently, the parser supports AND, OR,
614 and () operations. The structure of the LANL cgi makes it tricky to
615 perform NOTs, though this could be implemented if the desire were
618 Two class methods do the work. C<QRY::_parse_q> does a first-pass
619 parse of the query string. C<QRY::_make_q> interprets the parse tree
620 as returned by C<QRY::_parse_q> and produces an array of hash
621 structures that can be used directly by C<Bio::DB::Query::HIVQuery>
622 query execution methods. Validation of query fields and options is
623 performed at the C<Bio::DB::Query::HIVQuery> level, not here.
625 C<QRY> objects are collections of C<R> (or request) objects, which are
626 in turn collections of C<Q> (or atomic query) objects. C<Q> objects
627 represent a query on a single field, with match data options C<OR>ed
628 together, e.g. C<(A B)[subtype]>. C<R> objects collect C<Q> objects
629 that could be processed in a single HTTP request; i.e., a set of
630 atomic queries each having different fields C<AND>ed together, such as
632 (A B)[subtype] AND ('CCR5')[coreceptor] AND (US CA)[country]
634 The C<QRY> object collects C<R>s that cannot be reduced (through
635 logical operations) to a single HTTP request, e.g.
637 ((C)[subtype] AND (SI)[phenotype]) OR ( (D)[subtype] AND (NSI)[phenotype] ),
639 which cannot be got in one go through the current LANL cgi
640 implementation (as far as I can tell). The parser will simplify
643 ((C)[subtype] AND (SI)[phenotype]) OR ((C)[subtype] AND (NSI)[phenotype])
645 to the single request
647 (C)[subtype] AND (NSI SI)[phenotype]
651 The operators C<&> and C<|> are overloaded to C<QRY::And> and
652 C<QRY::Or>, to get Perl precedence and grouping for free. C<bool> is
653 overloaded to get symbolic tests such as C<if ($QRY) {stuff}>. C<==>
654 is overloaded with C<QRY::Eq> for convenience. No overloading is done
659 # a query algebra for HIVQuery
661 # Each Q object is an 'atomic' query, written as (data)[field]
662 # (a b ...)[X] equals (a)[X] | (b)[X] | ...
663 # Each R object represents a single HTTP request to the db
664 # contains an array of Q (atomic) objects (q1, q2, ...)
665 # the R object is interpreted as q1 & q2 & ...
666 # Each QRY object represents a series of HTTP requests to the db
667 # contains an array of R (request) objects (R1, R2, ...)
668 # the QRY object is interpreted as R1 | R2 | ...
670 # & and | operations are specified for each type
674 $QRY::NULL
= new QRY
();
684 # query language emulator
685 # supports only AND and OR, any groupings
688 # query atom: bareword [field] OR (bareword ...) [field]
689 # only single bareword allowed between []
690 # annotation fields in {} (only bareword lists allowed between {})
691 # () can group query atoms joined by operators (AND or OR)
692 # () containing only barewords MUST be followed by a field descriptor [field]
693 # empty [] not allowed
694 # query atoms joined with AND by default
695 # barewords are associated (ORed within) the next field descriptor in the line
697 # follow the parse tree, creating new QRY objects as needed in @q, and
698 # construct a logical expression using & and | symbols.
699 # These are overloaded for doing ands and ors on QRY objects;
700 # to get the final QRY object, eval the resulting expression $q_expr.
701 # QRY object will be translated into (possibly multiple) hashes
702 # conforming to HIVQuery parameter requirements.
709 Usage : QRY::_make_q($parsetree)
710 Function: creates hash structures suitable for HIVQuery from parse tree
711 returned by QRY::_parse_q
713 Returns : array of hashrefs of query specs
720 my ($q_expr, @q, @an, $query, @dbq);
721 _make_q_guts
($ptree, \
$q_expr, \
@q, \
@an);
722 $query = eval $q_expr;
723 throw Bio
::Root
::Root
(-class=>'Bio::Root::Exception',
725 -value
=>$q_expr) if $@
;
726 return {} if $query->isnull;
727 foreach my $rq ($query->requests) {
728 my $h = {'query'=>{}};
729 foreach ($rq->atoms) {
730 my @d = split(/\s+/, $_->dta);
735 $h->{'query'}{$_->fld} = (@d == 1) ?
$d[0] : [@d];
737 $h->{'annot'} = [@an] if @an;
745 Title : _make_q_guts (Internal class method)
746 Usage : _make_q_guts($ptree, $q_expr, $qarry, $anarry)
747 Function: traverses the parse tree returned from QRY::_parse_q, checking
748 syntax and creating HIVQuery-compliant query structures
751 Args : $parse_tree (hashref), $query_expression (scalar string ref),
752 $query_array (array ref : stack for returning query structures),
753 $annotation_array (array ref : stack for returning annotation
759 my ($ptree, $q_expr, $qarry, $anarry) = @_;
762 foreach (@
{$ptree->{cont
}}) {
772 for my $dl ($_->{delim
}) {
773 ($dl =~ m{\(}) && do {
774 if (grep /^HASH/, @
{$_->{cont
}}) {
775 $$q_expr .= "&" unless !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
777 _make_q_guts
($_,$q_expr,$qarry,$anarry);
782 my $c = join(' ',@
{$_->{cont
}});
784 Bio
::Root
::Root
->throw("query syntax error: unmatched ['\"]") if (@c = ($c =~ /(['"])/g)) % 2;
785 @c = split(/\s*(['"])\s*/, $c);
789 $c = join('', ($c, shift @c, shift @c));
794 push @words, split(/\s+/,$c);
800 ($dl =~ m{\[}) && do {
801 Bio
::Root
::Root
->throw("syntax error: empty field descriptor") unless @
{$_->{cont
}};
802 Bio
::Root
::Root
->throw("syntax error: more than one field descriptor in square brackets") unless @
{$_->{cont
}} == 1;
804 push @
{$qarry}, new QRY
( new R
( new Q
( $_->{cont
}->[0], @words)));
805 # add default operation if nec
806 $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/);
807 $$q_expr .= "\$q[".$#$qarry."]";
811 ($dl =~ m{\{}) && do {
812 foreach my $an (@
{$_->{cont
}}) {
813 ($an =~ /^HASH/) && do {
814 if ($an->{delim
} eq '[') {
815 push @
$anarry, @
{$an->{cont
}};
818 Bio
::Root
::Root
->throw("query syntax error: only field descriptors (with or without square brackets) allowed in annotation spec");
835 do { # else, bareword
842 m/['"]/ && ($o = !$o);
845 Bio
::Root
::Root
->throw("query syntax error: no search fields specified")
846 unless $$q_expr =~ /q\[[0-9]+\]/;
849 throw Bio
::Root
::Root
(-class=>'Bio::QueryStringSyntax::Exception',
858 Usage : QRY::_parse_q($query_string)
859 Function: perform first pass parse of a query string with some syntax
860 checking, return a parse tree suitable for QRY::_make_q
861 Example : QRY::_parse_q(" to[be] OR (not to)[be] ");
867 # parse qry string into a branching tree structure
868 # each branch tagged by the opening delimiter ( key 'delim' )
869 # content (tokens and subbranch hashes) placed in l2r order in
874 my $illegal = qr/[^a-zA-Z0-9-_,\.\(\[\{\}\]\)\s'"]/;
875 my $pdlm = qr/[\{\[\(\)\]\}]/;
876 my %md = ('('=>')', '['=>']','{'=>'}');
877 my @tok = grep !/^\s*$/, split /($pdlm)/, $qstr;
878 return {} unless @tok;
884 Bio
::Root
::Root
->throw("query syntax error: illegal character") if $qstr =~ /$illegal/;
886 $ptree = $p = {'delim'=>'*'};
892 my $new = {'delim'=>$_};
893 $p->{cont
} = [] unless $p->{cont
};
894 push @
{$p->{cont
}}, $new;
904 Bio
::Root
::Root
->throw("query syntax error: unmatched \"$_\"") unless $p;
907 Bio
::Root
::Root
->throw("query syntax error: saw \"$_\" before matching \"$md{$d}\"");
912 $p->{cont
} = [] unless $p->{cont
};
913 push @
{$p->{cont
}}, split(/\s+/);
918 throw Bio
::Root
::Root
(-class=>'Bio::QueryStringSyntax::Exception',
928 =head4 QRY Constructor
930 Title : QRY constructor
931 Usage : $QRY = new QRY()
935 Args : array of R objects, optional
943 $self->{requests
} = [];
944 bless($self, $class);
945 $self->put_requests(@args) if @args;
949 ## QRY instance methods
951 =head3 INSTANCE METHODS
956 Usage : $QRY->requests
957 Function: get/set array of requests comprising this QRY object
960 Args : array of class R objects
966 $self->put_requests(@_) if @_;
967 return @
{$self->{'requests'}};
973 Usage : $QRY->put_request(@R)
974 Function: add object of class R to $QRY
977 Args : [an array of] of class R object[s]
985 Bio
::Root
::Root
->throw('requires type R (request)') unless ref && $_->isa('R');
986 push @
{$self->{requests
}}, $_;
995 Function: test if QRY object is null
997 Returns : 1 if null, 0 otherwise
1004 return ($self->requests) ?
0 : 1;
1010 Usage : print $QRY->A
1011 Function: get a string representation of QRY object
1013 Returns : string scalar
1020 return join( "\n", map {$_->A} $self->requests );
1027 Function: get number of class R objects contained by QRY object
1036 return scalar @
{$self->{'requests'}};
1042 Usage : $QRY2 = $QRY1->clone;
1043 Function: create and return a clone of the object
1045 Returns : object of class QRY
1053 my $ret = new QRY
();
1054 foreach ($self->requests) {
1055 $ret->put_requests($_->clone);
1060 ## QRY class methods
1062 =head3 CLASS METHODS
1067 Usage : $QRY3 = QRY::Or($QRY1, $QRY2)
1068 Function: logical OR for QRY objects
1070 Returns : a QRY object
1071 Args : two class QRY objects
1077 my ($q, $r, $rev_f) = @_;
1078 Bio
::Root
::Root
->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1079 Bio
::Root
::Root
->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1083 elsif ($r->isnull) {
1086 do {my $qq = $q; $q=$r; $r=$qq} if ($q->len > $r->len);
1087 my @rq_r = $r->requests;
1088 my @rq_q = $q->requests;
1089 my (@cand_rq, @ret_rq);
1090 # search for simplifications
1095 while (my $rq = pop @now) {
1096 my @result = R
::Or
($rq, $_);
1098 push @cand_rq, $result[0]->clone;
1106 push @cand_rq, $_->clone unless ($found);
1107 # @now becomes unexamined @rq_q's plus failed @rq_q's
1108 @now = (@now, @nxt);
1110 push @cand_rq, map {$_->clone} @now; # add all failed @rq_q's
1111 # squeeze out redundant requests
1112 while (my $rq = pop @cand_rq) {
1113 push @ret_rq, $rq unless @cand_rq && grep {R
::Eq
($rq, $_)} @cand_rq;
1115 return new QRY
( @ret_rq );
1121 Usage : $QRY3 = QRY::And($QRY1, $QRY2)
1122 Function: logical AND for QRY objects
1124 Returns : a QRY object
1125 Args : two class QRY objects
1130 my ($q, $r, $rev_f) = @_;
1131 Bio
::Root
::Root
->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1132 Bio
::Root
::Root
->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1133 return ($QRY::NULL
) if ($q->isnull || $r->isnull);
1134 my (@cand_rq, @ret_rq);
1135 foreach my $rq_r ($r->requests) {
1136 foreach my $rq_q ($q->requests) {
1137 my ($rq) = R
::And
($rq_r, $rq_q);
1138 push @cand_rq, $rq unless $rq->isnull;
1141 return $QRY::NULL
unless @cand_rq;
1142 # squeeze out redundant requests
1143 while (my $rq = pop @cand_rq) {
1144 push @ret_rq, $rq unless @cand_rq && grep {R
::Eq
($rq, $_)} @cand_rq;
1146 return new QRY
( @ret_rq );
1152 Usage : QRY::Bool($QRY1)
1153 Function: allows symbolic testing of QRY object when bool overloaded
1154 Example : do {stuff} if $QRY1 *same as* do {stuff} if !$QRY1->isnull
1156 Args : a class QRY object
1162 Bio
::Root
::Root
->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1163 return $q->isnull ?
0 : 1;
1169 Usage : QRY::Eq($QRY1, $QRY2)
1170 Function: test if R objects in two QRY objects are the same
1171 (irrespective of order)
1173 Returns : 1 if equal, 0 otherwise
1174 Args : two class QRY objects
1179 my ($q, $r, $rev_f) = @_;
1180 Bio
::Root
::Root
->throw('requires type QRY') unless ref($q) && $q->isa('QRY');
1181 Bio
::Root
::Root
->throw('requires type QRY') unless ref($r) && $r->isa('QRY');
1182 return 0 unless $q->len == $r->len;
1183 foreach my $rq_q ($q->requests) {
1185 foreach my $rq_r ($r->requests) {
1186 if (R
::Eq
($rq_q,$rq_r)) {
1191 return 0 unless $found;
1198 =head2 Class R - request objects for QRY algebra
1202 $R = new R( $q1, $q2 );
1204 $R->del_atoms('coreceptor', 'phenotype');
1206 $R1 = new R( new Q('subtype', 'B') );
1207 $R2 = new R( new Q('subtype', 'B C'),
1208 new Q('country', 'US') );
1209 R::Eq( (R::And($R1, $R2))[0],
1210 new R( new Q('subtype', 'B' ),
1211 new Q('country', 'US') )); # returns 1
1212 QRY::Eq( new QRY(R::Or($R1, $R2)), new QRY($R1, $R2) ); # returns 1
1213 R::In( (R::And($R1, $R2))[0], $R1 ); # returns 1
1217 Class R objects contain a list of atomic queries (class Q
1218 objects). Each class R object represents a single HTTP request to the
1219 LANL DB. When converted to a DB query, the class Q objects contained
1220 by an R object are effectively C<AND>ed.
1233 =head4 R constructor
1235 Title : R constructor
1236 Usage : $R = new R()
1237 Function: create a new R (request) object
1239 Returns : class R (request) object
1240 Args : optional, array of class Q objects
1248 $self->{atoms
} = {};
1249 bless($self, $class);
1250 $self->put_atoms(@args) if @args;
1254 ## R instance methods
1256 =head3 INSTANCE METHODS
1262 Function: get number of class Q objects contained in R object
1271 return scalar @
{[keys %{$self->{'atoms'}}]};
1277 Usage : $R->atoms( [optional $field])
1278 Function: get array of class Q (atomic query) objects in class R object
1279 Example : $R->atoms(); $R->atoms('coreceptor')
1280 Returns : array of class Q objects (all Qs or those corresponding to $field
1282 Args : optional, scalar string
1288 # returns an array of atoms
1289 # no arg: all atoms;
1290 # args: atoms with specified fields
1292 my @flds = (@_ ?
@_ : keys %{$self->{'atoms'}});
1293 return wantarray ?
map { $self->{'atoms'}->{$_} } @flds : $self->{'atoms'}->{$flds[0]};
1300 Function: get array of fields of all Q objects contained in $R
1302 Returns : array of scalars
1309 return keys %{$self->{'atoms'}};
1315 Usage : $R->put_atoms( @q )
1316 Function: AND an atomic query (class Q object) to the class R object's list
1319 Args : an [array of] class Q object[s]
1324 # AND this atom to the request
1329 Bio
::Root
::Root
->throw('requires type Q (atom)') unless ref && $_->isa('Q');
1330 if ($self->atoms($_->fld)) {
1331 my $a = Q
::qand
( $self->atoms($_->fld), $_ );
1333 delete $self->{'atoms'}->{$_->fld};
1336 $self->{atoms
}->{$_->fld} = $a->clone;
1340 $self->{atoms
}->{$_->fld} = $_->clone;
1349 Usage : $R->del_atoms( @qfields )
1350 Function: removes class Q objects from R object's list according to the
1351 field names given in arguments
1353 Returns : the class Q objects deleted
1354 Args : scalar array of field names
1359 # remove atoms by field from request
1363 return () unless @args;
1366 push @ret, delete $self->{'atoms'}->{$_};
1375 Function: test if class R object is null
1377 Returns : 1 if null, 0 otherwise
1384 return ($self->len) ?
0 : 1;
1391 Function: get a string representation of class R object
1393 Returns : string scalar
1400 my @a = sort {$a->fld cmp $b->fld} $self->atoms;
1401 return join(" ", map {$_->A} @a);
1407 Usage : $R2 = $R1->clone;
1408 Function: create and return a clone of the object
1410 Returns : object of class R
1419 foreach ($self->atoms) {
1420 $ret->put_atoms($_->clone);
1427 =head3 CLASS METHODS
1432 Usage : R::In($R1, $R2)
1433 Function: tests whether the query represented by $R1 would return a subset
1434 of items returned by the query represented by $R2
1435 Example : print "R2 gets those and more" if R::In($R1, $R2);
1436 Returns : 1 if R1 is subset of R2, 0 otherwise
1437 Args : two class R objects
1444 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1445 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1446 return 1 if ($s->isnull);
1448 my @cf = grep {defined} map {my $f=$_; grep /^$f$/,$s->fields} $t->fields;
1449 return 0 unless @cf==$t->len;
1451 my @sd = split(/\s+/, $s->atoms($_)->dta);
1452 my @td = split(/\s+/, $t->atoms($_)->dta);
1453 my @cd = grep {defined} map {my $d=$_; grep /^$d$/, @td} @sd;
1454 return 0 unless @cd==@sd;
1462 Usage : @Rresult = R::And($R1, $R2)
1463 Function: logical AND for R objects
1465 Returns : an array containing class R objects
1466 Args : two class R objects
1473 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1474 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1475 return ($R::NULL
) if ($s->isnull || $t->isnull);
1477 do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len );
1478 # $t has at least as many fields defined than $s ($t is more restrictive)
1481 my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields;
1488 # And the atoms with identical fields
1491 my ($a) = Q
::qand
($s->atoms($_), $t->atoms($_));
1496 $ret->put_atoms($a);
1499 # put the private atoms
1500 $ret->put_atoms($u->atoms, $v->atoms);
1508 Usage : @Rresult = R::Or($R1, $R2)
1509 Function: logical OR for R objects
1511 Returns : an array containing class R objects
1512 Args : two class R objects
1519 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1520 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1524 elsif ($t->isnull) {
1527 return $s->clone if (R
::In
($t, $s));
1528 return $t->clone if (R
::In
($s, $t));
1531 do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len );
1533 my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields;
1535 if ($t->len == @cf) {
1536 # all atoms equal within fields but one? If yes, simplify...
1537 my @df = grep {!Q
::qeq
($s->atoms($_), $t->atoms($_))} @cf;
1539 my ($a) = Q
::qor
($s->atoms($df[0]), $t->atoms($df[0]));
1540 my $ret = $s->clone;
1541 $ret->del_atoms($df[0]);
1542 $ret->put_atoms($a);
1547 # neither request contains the other, and the requests cannot be
1548 # simplified; reflect back (clones of) the input...
1549 return ($s->clone, $t->clone);
1556 Usage : R::Eq($R1, $R2)
1557 Function: test if class Q objects in two R objects are the same
1558 (irrespective of order)
1560 Returns : 1 if equal, 0 otherwise
1561 Args : two class R objects
1568 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($s) && $s->isa('R');
1569 Bio
::Root
::Root
->throw('requires type R (request)') unless ref($t) && $t->isa('R');
1570 my @sf = $s->fields;
1571 my @tf = $t->fields;
1572 return 0 unless @sf==@tf;
1573 my @cf = grep {defined} map {my $f=$_; grep /^$f$/,@sf} @tf;
1574 return 0 unless @cf==@tf;
1576 return 0 unless Q
::qeq
($s->atoms($_), $t->atoms($_));
1582 =head2 Class Q - atomic query objects for QRY algebra
1586 $q = new Q('coreceptor', 'CXCR4 CCR5');
1587 $u = new Q('coreceptor', 'CXCR4');
1588 $q->fld; # returns 'coreceptor'
1589 $q->dta; # returns 'CXCR4 CCR5'
1590 print $q->A; # prints '(CXCR4 CCR5)[coreceptor]
1591 Q::qeq($q, $u); # returns 0
1592 Q::qeq( Q::qor($q, $q), $q ); # returns 1
1593 Q::qin($u, $q) # returns 1
1594 Q::qeq(Q::qand($u, $q), $u ); # returns 1
1598 Class Q objects represent atomic queries, that can be described by a
1599 single LANL cgi parameter=value pair. Class R objects (requests) are
1600 built from class Qs. The logical operations at the higher levels
1601 (C<QRY, R>) ultimately depend on the lower level operations on Qs:
1602 C<qeq, qin, qand, qor>.
1614 =head4 Q constructor
1616 Title : Q constructor
1617 Usage : $q = new Q($field, $data)
1618 Function: create a new Q (atomic query) object
1620 Returns : class Q object
1621 Args : optional $field, $data strings
1627 my ($class,@args) = @_;
1629 foreach (@args) { s/^\s+//; s/\s+$//; }
1630 my ($fld, @dta) = @args;
1632 $self->{dta
}=join(" ", @dta);
1633 bless($self, $class);
1637 ## Q instance methods
1639 =head3 INSTANCE METHODS
1645 Function: test if class Q object is null
1647 Returns : 1 if null, 0 otherwise
1654 Bio
::Root
::Root
->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1655 return 1 unless (($self->fld && length($self->fld)) || ($self->dta && length($self->dta)));
1662 Usage : $q->fld($field)
1663 Function: get/set fld (field name) property
1672 Bio
::Root
::Root
->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1677 return $self->{fld
}=$f;
1679 return $self->{fld
};
1686 Usage : $q->dta($data)
1687 Function: get/set dta (whsp-separated data string) property
1696 Bio
::Root
::Root
->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1697 my $d = join(" ", @_);
1701 return $self->{dta
} = $d;
1703 return $self->{dta
};
1710 Function: get a string representation of class Q object
1712 Returns : string scalar
1719 Bio
::Root
::Root
->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1720 my @a = split(/\s+/, $self->dta);
1722 return "(".join(' ', sort {$a cmp $b} @a).")[".$self->fld."]";
1728 Usage : $q2 = $q1->clone;
1729 Function: create and return a clone of the object
1731 Returns : object of class Q
1738 Bio
::Root
::Root
->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q');
1739 my $ret = new Q
($self->fld, $self->dta);
1745 =head3 CLASS METHODS
1750 Usage : Q::qin($q1, $q2)
1751 Function: tests whether the query represented by $q1 would return a subset
1752 of items returned by the query represented by $q2
1753 Example : print "q2 gets those and more" if Q::qin($q1, $q2);
1754 Returns : 1 if q1 is subset of q2, 0 otherwise
1755 Args : two class Q objects
1761 Bio
::Root
::Root
->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
1762 return 0 unless $a->fld eq $b->fld;
1763 return Q
::qeq
( $b, Q
::qor
($a, $b) );
1769 Usage : Q::qeq($q1, $q2)
1770 Function: test if fld and dta properties in two class Q objects are the same
1771 (irrespective of order)
1773 Returns : 1 if equal, 0 otherwise
1774 Args : two class Q objects
1781 Bio
::Root
::Root
->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
1782 return 0 unless $a->fld eq $b->fld;
1783 my @ad = unique
(split(/\s+/,$a->dta));
1784 my @bd = unique
(split(/\s+/,$b->dta));
1785 return 0 unless @ad==@bd;
1786 my @cd = grep {defined} map {my $f = $_; grep /^$f$/, @ad} @bd;
1793 Usage : @qresult = Q::qor($q1, $q2)
1794 Function: logical OR for Q objects
1796 Returns : an array of class Q objects
1797 Args : two class Q objects
1805 Bio
::Root
::Root
->throw("requires type Q (atom)") unless ref && $_->isa('Q');
1809 @a = grep {!$_->isnull} @a;
1810 return ($Q::NULL
) unless @a > 0;
1811 # list of unique flds
1812 @f = unique
(map {$_->fld} @a);
1813 foreach my $f (@f) {
1814 my @fobjs = grep {$_->fld eq $f} @a;
1815 my @d = unique
(map {split(/\s/, $_->dta)} @fobjs );
1816 my $r = new Q
($f, @d);
1825 Usage : @qresult = Q::And($q1, $q2)
1826 Function: logical AND for R objects
1828 Returns : an array of class Q objects
1829 Args : two class Q objects
1836 Bio
::Root
::Root
->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q');
1838 if (ref $a eq 'ARRAY') {
1839 foreach my $ea (@
$a) {
1840 push @ret, qand
( $ea, $b );
1842 return qor
(@ret); # simplify
1844 elsif (ref $b eq 'ARRAY') {
1845 foreach my $eb (@
$b) {
1846 push @ret, qand
( $a, $eb);
1849 return qor
(@ret); # simplify
1852 return ($Q::NULL
) if ($a->isnull || $b->isnull);
1853 if ($a->fld eq $b->fld) {
1854 # find intersection of data
1856 @ad = split(/\s+/, $a->dta);
1857 @ad{@ad} = (1) x
@ad;
1858 @bd = split(/\s+/, $b->dta);
1862 my $r = new Q
($a->fld,
1864 map {$ad{$_} == 2 ?
$_ : undef} keys %ad);
1865 return (length($r->dta) > 0) ?
($r) : ($Q::NULL
);
1878 Usage : @ua = unique(@a)
1879 Function: return contents of @a with duplicates removed
1895 =head2 Additional tools for Bio::AnnotationCollectionI
1899 $seq->annotation->put_value('patient_id', 1401)
1900 $seq->annotation->get_value('patient_ids') # returns 1401
1901 $seq->annotation->put_value('patient_group', 'MassGenH')
1902 $seq->annotation->put_value(['clinical', 'cd4count'], 503);
1903 $seq->annotation->put_value(['clinical', 'virus_load'], 150805);
1904 foreach ( qw( cd4count virus_load ) ) {
1905 $blood_readings{$_} = $seq->annonation->get_value(['clinical', $_]);
1910 C<get_value()> and C<put_value> allow easy creation of and access to an annotation collection tree with nodes of L<Bio::Annotation::SimpleValue>. These methods obiviate direct accession of the SimpleValue objects.
1914 package Bio
::AnnotationCollectionI
;
1916 use Bio
::Annotation
::SimpleValue
;
1921 Usage : $ac->get_value($tagname) -or-
1922 $ac->get_value( $tag_level1, $tag_level2,... )
1923 Function: access the annotation value assocated with the given tags
1926 Args : an array of tagnames that descend into the annotation tree
1935 return "" unless @_;
1936 while ($_ = shift @args) {
1937 @h = $self->get_Annotations($_);
1938 if (ref($h[0]->{value
})) {
1939 $self = $h[0]->{value
}; # must be another Bio::AnnotationCollectionI
1945 return $h[0] && $h[0]->{value
} ; # now the last value.
1951 Usage : $ac->put_value($tagname, $value) -or-
1952 $ac->put_value([$tag_level1, $tag_level2, ...], $value) -or-
1953 $ac->put_value( [$tag_level1, $tag_level2, ...] )
1954 Function: create a node in an annotation tree, and assign a scalar value to it
1955 if a value is specified
1957 Returns : scalar or a Bio::AnnotationCollection object
1958 Args : $tagname, $value scalars (can be specified as -KEYS=>$tagname,
1959 -VALUE=>$value) -or-
1960 \@tagnames, $value (or as -KEYS=>\@tagnames, -VALUE=>$value )
1961 Note : If intervening nodes do not exist, put_value creates them, replacing
1962 existing nodes. So if $ac->put_value('x', 10) was done, then later,
1963 $ac->put_value(['x', 'y'], 20), the original value of 'x' is trashed, and $ac->get_value('x') will now return the annotation collection
1972 my ($keys, $value) = $self->_rearrange([qw( KEYS VALUE )], @args);
1973 my (@keys, $lastkey);
1974 $value ||= new Bio
::Annotation
::Collection
;
1975 @keys = (ref($keys) eq 'ARRAY') ? @
$keys : ($keys);
1976 $lastkey = pop @keys;
1978 my $a = $self->get_value($_);
1979 if (ref($a) && $a->isa('Bio::Annotation::Collection')) {
1983 # replace an old value
1984 $self->remove_Annotations($_) if $a;
1985 my $ac = new Bio
::Annotation
::Collection
;
1986 $self->add_Annotation(new Bio
::Annotation
::SimpleValue
(
1994 if ($self->get_value($lastkey)) {
1995 # replace existing value
1996 ($self->get_Annotations($lastkey))[0]->{value
} = $value;
1999 $self->add_Annotation(new Bio
::Annotation
::SimpleValue
(