File Coverage

blib/lib/Bio/ConnectDots/DotQuery.pm
Criterion Covered Total %
statement 25 125 20.0
branch 3 44 6.8
condition 0 9 0.0
subroutine 8 22 36.3
pod 0 14 0.0
total 36 214 16.8


line stmt bran cond sub pod time code
1             package Bio::ConnectDots::DotQuery;
2 1     1   32265 use vars qw(@ISA @AUTO_ATTRIBUTES @OTHER_ATTRIBUTES %SYNONYMS %DEFAULTS);
  1         4  
  1         191  
3 1     1   8 use strict;
  1         3  
  1         43  
4             #use lib "/users/ywang/temp";
5 1     1   768 use Bio::ConnectDots::Connector;
  1         3  
  1         38  
6 1     1   875 use Bio::ConnectDots::Dot;
  1         3  
  1         41  
7 1     1   30859 use Bio::ConnectDots::DotQuery::Output;
  1         4  
  1         40  
8 1     1   1684 use Bio::ConnectDots::DotQuery::Constraint;
  1         4  
  1         131  
9 1     1   9 use Class::AutoClass;
  1         2  
  1         1591  
10             @ISA = qw(Class::AutoClass); # AutoClass must be first!!
11              
12             @AUTO_ATTRIBUTES=qw(input dottable outputs constraints name2output);
13             @OTHER_ATTRIBUTES=qw();
14             %SYNONYMS=();
15             %DEFAULTS=(name2output=>{});
16             Class::AutoClass::declare(__PACKAGE__);
17              
18             sub _init_self {
19 1     1   969 my($self,$class,$args)=@_;
20 1 50       5 return unless $class eq __PACKAGE__; # to prevent subclasses from re-running this
21 1 50       26 $self->throw("Required parameter -input missing") unless $self->input;
22 1 50       30 $self->throw("Required parameter -outputs missing") unless $self->outputs;
23             }
24              
25 0     0 0   sub connectdots {$_[0]->dottable->connectdots;}
26 0     0 0   sub name {$_[0]->dottable->name;}
27 0     0 0   sub db {$_[0]->dottable->db;}
28              
29             sub execute {
30 0     0 0   my($self)=@_;
31 0           $self->parse; # parse syntax
32 0           $self->normalize; # normalize syntax
33 0           $self->validate; # do semantic checks
34 0           $self->db_execute; # really execute -- implemented in subclasses
35             }
36             sub parse {
37 0     0 0   my($self)=@_;
38 0           $self->parse_outputs;
39 0           $self->parse_constraints;
40             }
41             sub normalize {
42 0     0 0   my($self)=@_;
43 0           $self->normalize_outputs;
44 0           $self->normalize_constraints;
45             }
46             sub validate {
47 0     0 0   my($self)=@_;
48 0           $self->validate_outputs; # implemented in subclass mixins
49 0           $self->validate_constraints; # implemented in subclass mixins
50             }
51             sub parse_outputs {
52 0     0 0   my($self)=@_;
53 0           my $outputs=parse Bio::ConnectDots::DotQuery::Output($self->outputs);
54 0           $self->outputs($outputs);
55             }
56             sub normalize_outputs {
57 0     0 0   my($self)=@_;
58 0           my $outputs=$self->outputs;
59 0           my $normalized=[];
60 0           @$normalized=map {$_->normalize} @$outputs;
  0            
61 0           $self->outputs($normalized);
62 0           my $name2output=$self->name2output;
63 0           for my $output (@$normalized) {
64 0           my $output_name=$output->output_name;
65 0 0         $self->throw("Duplicate output: $output") if $name2output->{$output_name};
66 0           $name2output->{$output_name}=$output;
67             }
68             }
69             sub parse_constraints {
70 0     0 0   my($self)=@_;
71 0           my $constraints=parse Bio::ConnectDots::DotQuery::Constraint($self->constraints);
72 0           $self->constraints($constraints);
73             }
74             sub normalize_constraints {
75 0     0 0   my($self)=@_;
76 0           my $constraints=$self->constraints;
77 0           my $normalized=[];
78 0           @$normalized=map {$_->normalize} @$constraints;
  0            
79 0           $self->constraints($normalized);
80             }
81              
82             # 'utility' method used in all subclasses
83             # generate core where classes for constraint
84             sub constraint_where {
85 0     0 0   my($self,$constraint,$cs_id,$cd)=@_;
86 0           my @where;
87 0           push(@where,"$cd.connectorset_id=$cs_id");
88 0           my $label_ids=$constraint->label_ids;
89             # if $label_ids is empty, the label was '*' -- matches all ids
90 0 0         if (@$label_ids==1) {
    0          
91 0           push(@where,"$cd.label_id=".$label_ids->[0]);
92             } elsif (@$label_ids>1) {
93 0           push(@where,"$cd.label_id IN (".join(",",@$label_ids).")");
94             }
95 0           my($op,$constants)=($constraint->op,$constraint->constants);
96 0           my $db=$self->db;
97 0           my @constants=map {$db->quote_dot($_)} @$constants;
  0            
98 0 0         if ($op=~/IN/) { # IN or NOT IN
    0          
99 0           push(@where,"$cd.id $op (".join(",",@constants).")");
100             } elsif ($op ne 'EXISTS') { # EXISTS has no constants -- needs no SQL condition
101             # should only be 1 constant by now -- see Constraint::normalize
102 0           push(@where,"$cd.id $op ".$db->quote($constants->[0]));
103             }
104 0 0         wantarray? @where: \@where;
105             }
106              
107             # Removes entries from a table that are subsets of other rows on one identifier
108             # usage: remove_subsets( , )
109             sub remove_subsets {
110 0     0 0   my ($self, $dbh, $TABLE, $key_name, $output_cols) = @_;
111            
112             # setup translation hash and assign key index
113 0           my $key_index;
114 0           for(my $i=0; $i<@$output_cols; $i++) {
115 0 0         $key_index = $i if $key_name eq $output_cols->[$i];
116             }
117              
118 0           my $iterator = $dbh->prepare("SELECT DISTINCT * FROM $TABLE ORDER BY $key_name");
119 0           $iterator->execute();
120 0           my @list;
121             my @delete;
122 0           my $old_key;
123 0           my $key_index=0;
124 0           while (my @cols = $iterator->fetchrow_array()) {
125 0           my $key = $cols[$key_index];
126 0 0         if($key ne $old_key) { # reset lists
127 0           @list = undef;
128 0           $old_key = $key;
129             }
130             # remove subset entries on image_id
131            
132 0 0         if (@list) { # update list to exclude subsets
133 0           my $add_it = 1;
134 0           for(my $i=0; $i<=$#list; $i++) {
135 0 0         next unless $list[$i];
136 0 0         if ($self->subset(\@cols, $list[$i]) ) { # skip this row if it's a subset
137 0           $add_it = 0;
138 0           push @delete, \@cols;
139 0           last;
140             }
141 0 0         if ($self->subset($list[$i], \@cols)) { # remove entries that are subset of present
142 0           push @delete, $list[$i];
143 0           $list[$i] = '';
144             }
145             }
146 0 0         push @list, \@cols if $add_it; # add non subset rows
147             }
148 0           else { push @list, \@cols; }
149             }
150            
151             ### delete rows from table
152 0           foreach my $cols (@delete) {
153 0 0         next unless $cols; # ignore empty rows in the list
154 0           my $sql = "DELETE FROM $TABLE WHERE";
155 0           for(my $i=0; $i<@$output_cols; $i++) {
156 0 0         $sql .= " AND" if $i>0;
157 0 0         if($cols->[$i]) {
158 0           $sql .= " $output_cols->[$i]='$cols->[$i]'";
159             }
160             else {
161 0           $sql .= " $output_cols->[$i] IS NULL";
162             }
163             }
164 0           $dbh->do($sql);
165             }
166             }
167              
168             ### returns true if first is a subset of second, false otherwise
169             sub subset {
170 0     0 0   my ($self, $first, $second) = @_; # pointers to the two lists to compare
171 0 0         return 0 if @{$first} > @{$second};
  0            
  0            
172 0           for (my $i=0; $i<@{$second}; $i++) {
  0            
173 0 0 0       return 0 if !$second->[$i] && $first->[$i]; # 0 1
174 0 0 0       return 0 if $first->[$i] && $second->[$i] && $first->[$i] ne $second->[$i]; # 1 != 1
      0        
175             }
176 0           return 1;
177             }
178              
179              
180              
181              
182             1;