[Bio] / FigWebServices / check_variants.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/check_variants.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 :     #
3 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     #
18 :    
19 :    
20 :     use FIG;
21 :     my $fig = new FIG;
22 :    
23 :     use Subsystem;
24 :    
25 :     use HTML;
26 :     use strict;
27 :    
28 :     use CGI;
29 :     my $cgi = new CGI;
30 :    
31 : overbeek 1.2 if (0)
32 : overbeek 1.1 {
33 :     my $VAR1;
34 :     eval(join("",`cat /tmp/check_vc_parms`));
35 :     $cgi = $VAR1;
36 :     # print STDERR &Dumper($cgi);
37 :     }
38 :    
39 :     if (0)
40 :     {
41 :     print $cgi->header;
42 :     my @params = $cgi->param;
43 :     print "<pre>\n";
44 :     foreach $_ (@params)
45 :     {
46 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
47 :     }
48 :    
49 :     if (0)
50 :     {
51 :     if (open(TMP,">/tmp/check_vc_parms"))
52 :     {
53 :     print TMP &Dumper($cgi);
54 :     close(TMP);
55 :     }
56 :     }
57 :     exit;
58 :     }
59 :    
60 :     my $html = [];
61 :     unshift @$html, "<TITLE>Check Variants</TITLE>\n";
62 :    
63 :     my $subsys = $cgi->param('subsystem');
64 :     my $roles = $cgi->param('roles');
65 :     my $definitions = $cgi->param('definitions');
66 :     my $rules = $cgi->param('rules');
67 :    
68 :     my(@rolesI,@rulesI,@definitionsI);
69 :     if ($roles =~ /\S/)
70 :     {
71 :     $roles =~ tr/\r/\n/;
72 :     @rolesI = grep { $_ } split(/\n/,$roles);
73 :     }
74 :    
75 :     if ($definitions =~ /\S/)
76 :     {
77 :     $definitions =~ tr/\r/\n/;
78 :     @definitionsI = grep { $_ } split(/\n/,$definitions);
79 :     }
80 :    
81 :     if ($rules =~ /\S/)
82 :     {
83 :     $rules =~ tr/\r/\n/;
84 :     @rulesI = grep { $_ } split(/\n/,$rules);
85 :     }
86 :    
87 :     if ((! $subsys) || (@rolesI < 1) || (@rulesI < 1))
88 :     {
89 :     my @sub = $fig->all_subsystems;
90 :     push(@$html,$cgi->start_form(-action => "check_variants.cgi", -method => 'get'),
91 :     $cgi->scrolling_list( -name => 'subsystem',
92 :     -values => [ sort @sub ],
93 :     -size => 1
94 :     ),$cgi->br,
95 :     $cgi->h2('Roles'),$cgi->textarea( -name => 'roles', -rows => 20, columns => 100), $cgi->br, $cgi->hr,$cgi->br,
96 :     $cgi->h2('Definitions'),$cgi->textarea( -name => 'definitions', -rows => 20, columns => 100), $cgi->hr,$cgi->br, $cgi->br,
97 :     $cgi->h2('Rules'),$cgi->textarea( -name => 'rules', -rows => 20, columns => 100), $cgi->br, $cgi->hr,$cgi->br,
98 :     $cgi->submit( 'Compute Predicted Variant Codes' ),
99 :     $cgi->end_form
100 :     );
101 :     }
102 :     else
103 :     {
104 :     my $col_headers_undef = ["Predicted Variant","Genome","Genus/Species"];
105 :     my $tab_undef = [];
106 :     my $col_headers_mismatch = ["Actual Variant","Predicted Variant","Genome","Genus/Species"];
107 :     my $tab_mismatch = [];
108 :    
109 :     my $subO = new Subsystem($subsys,$fig);
110 :     my %genomesS = map { $_ => 1 } $subO->get_genomes;
111 :    
112 :     my $encoding = [[],0]; # Encoding is a 2-tuple [Memory,NxtAvail]
113 :     my $abbrev_to_loc = {};
114 :    
115 :     my @roles = &load_roles($encoding,$abbrev_to_loc,\@rolesI);
116 :     &load_definitions($encoding,$abbrev_to_loc,\@definitionsI);
117 :     my @rules = &parse_rules($encoding,$abbrev_to_loc,\@rulesI);
118 :     my $n = @rules;
119 :     push(@$html,$cgi->h2("successfully parsed $n rules"));
120 :     my $role_to_pegs = {};
121 :     foreach my $role (@roles)
122 :     {
123 :     $role_to_pegs->{$role} = [ sort { &FIG::by_fig_id($a,$b) }
124 :     $fig->role_to_pegs($role)
125 :     ];
126 :     }
127 :    
128 :     my $operational = 0;
129 :     foreach my $genome (map { $_->[0] }
130 :     sort { $a->[1] cmp $b->[1] }
131 :     map { [$_,$fig->genus_species($_)] }
132 :     $fig->genomes('complete'))
133 :     {
134 :     my $vcT = &find_vc($encoding,$role_to_pegs,$abbrev_to_loc,\@rules,$fig,$genome);
135 :     if ($vcT > 0) { $operational++ }
136 :    
137 :     if (! $genomesS{$genome})
138 :     {
139 :     push(@$tab_undef,[$vcT,$genome,$fig->genus_species($genome)]);
140 :     }
141 :     else
142 :     {
143 :     my $vcS = $subO->get_variant_code_for_genome($genome);
144 :     if ($vcT ne $vcS)
145 :     {
146 :     push(@$tab_mismatch,[$vcS,$vcT,$genome,$fig->genus_species($genome)]);
147 :     }
148 :     }
149 :     }
150 :     push(@$html,$cgi->h2("Got $operational operational variants"));
151 :    
152 :     if (@$tab_undef > 0)
153 :     {
154 :     push(@$html,&HTML::make_table($col_headers_undef,$tab_undef,"Genomes to Be Added To Subsystem"),$cgi->br,$cgi->br);
155 :     }
156 :    
157 :     if (@$tab_undef > 0)
158 :     {
159 :     push(@$html,&HTML::make_table($col_headers_mismatch,$tab_mismatch,"Genomes With Mismatching Variant Codes"));
160 :     }
161 :     }
162 :     &HTML::show_page($cgi,$html);
163 :    
164 :    
165 :     sub find_vc {
166 :     my($encoding,$role_to_pegs,$abbrev_to_loc,$rules,$fig,$genome) = @_;
167 :    
168 :     my $vcT = undef;
169 :     my $rule;
170 :    
171 :     my $role;
172 :     my $relevant_genes = {};
173 :     foreach $role (sort keys(%$role_to_pegs))
174 :     {
175 :     $relevant_genes->{$role} = &gather_genes($fig,$genome,$role,$role_to_pegs);
176 :     }
177 :    
178 :     my($i,$matched);
179 :     for ($i=0, $matched=undef; (! defined($matched)) && ($i < @$rules); $i++)
180 :     {
181 :     $matched = &is_rule_true($rules->[$i],$relevant_genes);
182 :     }
183 :    
184 :     my $vcT = defined($matched) ? $matched : -1;
185 :     return $vcT;
186 :     }
187 :    
188 :     sub load_roles {
189 :     my($encoding,$abbrev_to_loc,$rolesI) = @_;
190 :    
191 :     my @roles = ();
192 :     foreach $_ (@$rolesI)
193 :     {
194 :     if ($_ =~ /^(\S+)\s+(\S.*\S)/)
195 :     {
196 :     my($abbrev,$role) = ($1,$2);
197 :     my $loc = &add_to_encoding($encoding,['role',$role]);
198 :     $abbrev_to_loc->{$abbrev} = $loc;
199 :     push(@roles,$role);
200 :     }
201 :     }
202 :     return @roles;
203 :     }
204 :    
205 :     sub add_to_encoding {
206 :     my($encoding,$val) = @_;
207 :    
208 :     my($mem,$nxt) = @$encoding;
209 :     $mem->[$nxt] = $val;
210 :     $encoding->[1]++;
211 :     return $nxt;
212 :     }
213 :    
214 :     sub load_definitions {
215 :     my($encoding,$abbrev_to_loc,$defI) = @_;
216 :    
217 :     foreach my $def (@$defI)
218 :     {
219 :     if ($def =~ /^(\S+)\s+(\S.*\S)/)
220 :     {
221 :     my($abbrev,$bool) = ($1,$2);
222 :     my $loc = &parse_bool($bool,$encoding,$abbrev_to_loc);
223 :     $abbrev_to_loc->{$abbrev} = $loc;
224 :     }
225 :     }
226 :     }
227 :    
228 :     sub parse_rules {
229 :     my($encoding,$abbrev_to_loc,$rulesI) = @_;
230 :    
231 :     my @rules = ();
232 :     foreach $_ (@$rulesI)
233 :     {
234 :     my($boolexp,$variant_code,$loc);
235 :     if (($_ =~ /^\s*(\S+)\s+(\S.*\S)\s*$/) &&
236 :     (($variant_code,$boolexp) = ($1,$2)) &&
237 :     ($loc = &parse_bool($boolexp,$encoding,$abbrev_to_loc)))
238 :     {
239 :     push(@rules,[$variant_code,[$encoding->[0],$loc]]);
240 :     }
241 :     }
242 :     return @rules;
243 :     }
244 :    
245 :     sub parse_bool {
246 :     my($s,$encoding,$abbrev_to_loc) = @_;
247 :    
248 :     my $input = $s;
249 :     my $abbrev;
250 :     foreach $abbrev (sort { length($b) <=> length($a) } keys(%$abbrev_to_loc))
251 :     {
252 :     my $loc = $abbrev_to_loc->{$abbrev};
253 :     my $abbrevQ = quotemeta $abbrev;
254 :     while ($s =~ s/(^|[\s\{,])($abbrevQ)($|[\s\},])/$1<$loc>$3/) {}
255 :     }
256 :     my $got = 0;
257 :     while ($s !~ /^\s*<\d+>\s*$/)
258 :     {
259 :     my $nxt = $encoding->[1];
260 :     if ($s =~ s/\(\s*(<\d+>)\s*\)/$1/)
261 :     {
262 :     $got = 1;
263 :     }
264 :     elsif ($s =~ s/not\s+<(\d+)>/<$nxt>/)
265 :     {
266 :     &add_to_encoding($encoding,["not",$1]);
267 :     $got = 1;
268 :     }
269 :     elsif ($s =~ s/<(\d+)>\s+and\s+<(\d+)>/<$nxt>/)
270 :     {
271 :     &add_to_encoding($encoding,["and",$1,$2]);
272 :     $got = 1;
273 :     }
274 :     elsif ($s =~ s/<(\d+)>\s+or\s+<(\d+)>/<$nxt>/)
275 :     {
276 :     &add_to_encoding($encoding,["or",$1,$2]);
277 :     $got = 1;
278 :     }
279 :     elsif ($s =~ s/<(\d+)>\s+->\s+<(\d+)>/<$nxt>/)
280 :     {
281 :     &add_to_encoding($encoding,["->",$1,$2]);
282 :     $got = 1;
283 :     }
284 :    
285 :     elsif ($s =~ s/(\d+)\s+of\s+\{\s*(<\d+>(,\s*<\d+>)+)\}/<$nxt>/)
286 :     {
287 :     my $n = $1;
288 :     my $args = $2;
289 :     my @args = map { $_ =~ /<(\d+)>/; $1 } split(/,\s*/,$args);
290 :     &add_to_encoding($encoding,["of",$n,[@args]]);
291 :     $got = 1;
292 :     }
293 :    
294 :     if (! $got)
295 :     {
296 :     print STDERR "failed to parse \'$input\'\nGot to \'$s\'\n";
297 :     }
298 :     }
299 :     return ($s =~ /^\s*<(\d+)>\s*$/) ? $1 : undef;
300 :     }
301 :    
302 :    
303 :     sub gather_genes {
304 :     my($fig,$genome,$role,$role_to_pegs) = @_;
305 :    
306 :     return [sort { &FIG::by_fig_id($a,$b) }
307 :     grep { &FIG::genome_of($_) eq $genome }
308 :     @{$role_to_pegs->{$role}} ];
309 :     }
310 :    
311 :     sub is_rule_true {
312 :     my($rule,$relevant_genes) = @_;
313 :    
314 :     my($variant,$exp) = @$rule;
315 :     return &is_true_exp($exp,$relevant_genes) ? $variant : undef;
316 :     }
317 :    
318 :     sub is_true_exp {
319 :     my($bool,$relevant_genes) = @_;
320 :    
321 :     my($nodes,$root) = @$bool;
322 :     my $val = $nodes->[$root];
323 :     if (! ref $val)
324 :     {
325 :     return &is_true_exp([$nodes,$val],$relevant_genes);
326 :     }
327 :     else
328 :     {
329 :     my $op = $val->[0];
330 :    
331 :     if ($op eq 'role')
332 :     {
333 :     my $x;
334 :     return (($x = $relevant_genes->{$val->[1]}) && (@$x > 0)) ? 1 : 0;
335 :     }
336 :     elsif ($op eq "of")
337 :     {
338 :     my $truth_value;
339 :     my $count = 0;
340 :     foreach $truth_value (map { &is_true_exp([$nodes,$_],$relevant_genes) } @{$val->[2]})
341 :     {
342 :     if ($truth_value) { $count++ }
343 :     }
344 :     return $val->[1] <= $count;
345 :     }
346 :     elsif ($op eq "not")
347 :     {
348 :     return &is_true_exp([$nodes,$val->[1]],$relevant_genes) ? 0 : 1;
349 :     }
350 :     else
351 :     {
352 :     my $v1 = &is_true_exp([$nodes,$val->[1]],$relevant_genes);
353 :     my $v2 = &is_true_exp([$nodes,$val->[2]],$relevant_genes);
354 :     if ($op eq "and") { return $v1 && $v2 };
355 :     if ($op eq "or") { return $v1 || $v2 };
356 :     if ($op eq "->") { return ((not $v1) || $v2) }
357 :     else
358 :     {
359 :     print STDERR &Dumper($val);
360 :     die "invalid expression";
361 :     }
362 :     }
363 :     }
364 :     }
365 :    
366 :     sub print_bool {
367 :     my($bool) = @_;
368 :    
369 :     my $s = &printable_bool($bool);
370 :     print $s,"\n";
371 :     }
372 :    
373 :     sub printable_bool {
374 :     my($bool) = @_;
375 :    
376 :     my($nodes,$root) = @$bool;
377 :     my $val = $nodes->[$root];
378 :    
379 :     if (! ref $val)
380 :     {
381 :     return &printable_bool([$nodes,$val]);
382 :     }
383 :     else
384 :     {
385 :     my $op = $val->[0];
386 :    
387 :     if ($op eq 'role')
388 :     {
389 :     return $val->[1];
390 :     }
391 :     elsif ($op eq "of")
392 :     {
393 :     my @expanded_args = map { &printable_bool([$nodes,$_]) } @{$val->[2]};
394 :     my $args = join(',',@expanded_args);
395 :     return "$val->[1] of {$args}";
396 :     }
397 :     elsif ($op eq "not")
398 :     {
399 :     return "($op " . &printable_bool([$nodes,$val->[1]]) . ")";
400 :     }
401 :     else
402 :     {
403 :     return "(" . &printable_bool([$nodes,$val->[1]]) . " $op " . &printable_bool([$nodes,$val->[2]]) . ")";
404 :     }
405 :     }
406 :     }
407 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3