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

Annotation of /FigWebServices/find_poss_subsys_instances.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (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 :     use Carp;
28 :    
29 :     use CGI;
30 :     my $cgi = new CGI;
31 :    
32 :     if (0)
33 :     {
34 :     my $VAR1;
35 :     eval(join("",`cat /tmp/find_subsys_parms`));
36 :     $cgi = $VAR1;
37 :     # print STDERR &Dumper($cgi);
38 :     }
39 :    
40 :     if (1)
41 :     {
42 :     print $cgi->header;
43 :     my @params = $cgi->param;
44 :     print "<pre>\n";
45 :     foreach $_ (@params)
46 :     {
47 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
48 :     }
49 :    
50 :     if (1)
51 :     {
52 :     if (open(TMP,">/tmp/find_subsys_parms"))
53 :     {
54 :     print TMP &Dumper($cgi);
55 :     close(TMP);
56 :     }
57 :     }
58 :     exit;
59 :     }
60 :    
61 :     my $html = [];
62 :     unshift @$html, "<TITLE>Find Instances of a Subsystem</TITLE>\n";
63 :    
64 :     my $subsys = $cgi->param('subsystem');
65 :     my $roles = $cgi->param('roles');
66 :     my $definitions = $cgi->param('definitions');
67 :     my $rules = $cgi->param('rules');
68 :     my @orgs = $cgi->param('korgs');
69 :     @orgs = map { $_ =~ /(\d+\.\d+)/; $1 } @orgs;
70 :    
71 :     my(@rolesI,@rulesI,@definitionsI);
72 :     if ($roles =~ /\S/)
73 :     {
74 :     $roles =~ tr/\r/\n/;
75 :     @rolesI = grep { $_ } split(/\n/,$roles);
76 :     }
77 :    
78 :     if ($definitions =~ /\S/)
79 :     {
80 :     $definitions =~ tr/\r/\n/;
81 :     @definitionsI = grep { $_ } split(/\n/,$definitions);
82 :     }
83 :    
84 :     if ($rules =~ /\S/)
85 :     {
86 :     $rules =~ tr/\r/\n/;
87 :     @rulesI = grep { $_ } split(/\n/,$rules);
88 :     }
89 :    
90 :     my %org_labels;
91 :    
92 :     if ((! $subsys) || (@rolesI < 1) || (@rulesI < 1))
93 :     {
94 :     my @orgs = ();
95 :     foreach my $org ($fig->genomes('complete'))
96 :     {
97 :     my $label = &compute_genome_label($fig, $org);
98 :     $org_labels{$org} = $label;
99 :     push(@orgs, $org);
100 :     }
101 :     @orgs = sort { lc( $org_labels{$a} ) cmp lc( $org_labels{$b} ) } @orgs;
102 :     my @org_names = map { $org_labels{$_} } @orgs;
103 :    
104 :     my @sub = $fig->all_subsystems;
105 :     push(@$html,$cgi->start_form(-action => "find_poss_subsys_instances.cgi", -method => 'get'),
106 :     $cgi->scrolling_list( -name => 'subsystem',
107 :     -values => [ sort @sub ],
108 :     -size => 1
109 :     ),$cgi->br,
110 :     $cgi->h2('Roles'),$cgi->textarea( -name => 'roles', -rows => 20, columns => 200), $cgi->br, $cgi->hr,$cgi->br,
111 :     $cgi->h2('Definitions'),$cgi->textarea( -name => 'definitions', -rows => 20, columns => 200), $cgi->hr,$cgi->br, $cgi->br,
112 :     $cgi->h2('Rules'),$cgi->textarea( -name => 'rules', -rows => 20, columns => 200), $cgi->br, $cgi->hr,$cgi->br,
113 :     $cgi->scrolling_list( -name => 'korgs',
114 :     -values => [ @orgs ],
115 :     -labels => \%org_labels,
116 :     -size => 10,
117 :     ), $cgi->br,
118 :     $cgi->submit( 'Compute Predicted Variant Codes' ),
119 :     $cgi->end_form
120 :     );
121 :     }
122 :     else
123 :     {
124 :     my $col_headers_undef = ["Predicted Variant","Genome","Genus/Species"];
125 :     my $tab_undef = [];
126 :     my $col_headers_mismatch = ["Actual Variant","Predicted Variant","Genome","Genus/Species"];
127 :     my $tab_mismatch = [];
128 :    
129 :     my $subO = new Subsystem($subsys,$fig);
130 :     my %genomesS = map { $_ => 1 } $subO->get_genomes;
131 :    
132 :     my $encoding = [[],0]; # Encoding is a 2-tuple [Memory,NxtAvail]
133 :     my $abbrev_to_loc = {};
134 :    
135 :     my @roles = &load_roles($cgi,$html,$encoding,$abbrev_to_loc,\@rolesI);
136 :     if (@roles < 1)
137 :     {
138 :     push(@$html,$cgi->h1("Roles are invalid"));
139 :     }
140 :     else
141 :     {
142 :     my $rc = &load_definitions($cgi,$html,$encoding,$abbrev_to_loc,\@definitionsI);
143 :     if (! $rc)
144 :     {
145 :     push(@$html,$cgi->h1("Definitions are invalid"));
146 :     }
147 :     else
148 :     {
149 :     my @rules = &parse_rules($cgi,$html,$encoding,$abbrev_to_loc,\@rulesI);
150 :     if (@rules < 1)
151 :     {
152 :     push(@$html,$cgi->h1("Rules are invalid"));
153 :     }
154 :     else
155 :     {
156 :     my $n = @rules;
157 :     push(@$html,$cgi->h2("successfully parsed $n rules"));
158 :     my $role_to_pegs = {};
159 :     foreach my $role (@roles)
160 :     {
161 :     $role_to_pegs->{$role} = [ sort { &FIG::by_fig_id($a,$b) }
162 :     $fig->role_to_pegs($role)
163 :     ];
164 :     }
165 :    
166 :     my $operational = 0;
167 :     foreach my $genome (map { $_->[0] }
168 :     sort { $a->[1] cmp $b->[1] }
169 :     map { [$_,$fig->genus_species($_)] }
170 :     $fig->genomes('complete'))
171 :     {
172 :     my $vcT = &find_vc($encoding,$role_to_pegs,$abbrev_to_loc,\@rules,$fig,$genome);
173 :     if ($vcT > 0) { $operational++ }
174 :    
175 :     if (! $genomesS{$genome})
176 :     {
177 :     push(@$tab_undef,[$vcT,$genome,$fig->genus_species($genome)]);
178 :     }
179 :     else
180 :     {
181 :     my $vcS = $subO->get_variant_code_for_genome($genome);
182 :     if ($vcT ne $vcS)
183 :     {
184 :     push(@$tab_mismatch,[$vcS,$vcT,$genome,$fig->genus_species($genome)]);
185 :     }
186 :     }
187 :     }
188 :     push(@$html,$cgi->h2("Got $operational operational variants"));
189 :    
190 :     if (@$tab_undef > 0)
191 :     {
192 :     push(@$html,&HTML::make_table($col_headers_undef,$tab_undef,"Genomes to Be Added To Subsystem"),$cgi->br,$cgi->br);
193 :     }
194 :    
195 :     if (@$tab_mismatch > 0)
196 :     {
197 :     push(@$html,&HTML::make_table($col_headers_mismatch,$tab_mismatch,"Genomes With Mismatching Variant Codes"));
198 :     }
199 :     }
200 :     }
201 :     }
202 :     }
203 :     &HTML::show_page($cgi,$html);
204 :    
205 :    
206 :     sub find_vc {
207 :     my($encoding,$role_to_pegs,$abbrev_to_loc,$rules,$fig,$genome) = @_;
208 :    
209 :     my $vcT = undef;
210 :     my $rule;
211 :    
212 :     my $role;
213 :     my $relevant_genes = {};
214 :     foreach $role (sort keys(%$role_to_pegs))
215 :     {
216 :     $relevant_genes->{$role} = &gather_genes($fig,$genome,$role,$role_to_pegs);
217 :     }
218 :    
219 :     my($i,$matched);
220 :     for ($i=0, $matched=undef; (! defined($matched)) && ($i < @$rules); $i++)
221 :     {
222 :     $matched = &is_rule_true($rules->[$i],$relevant_genes);
223 :     }
224 :    
225 :     my $vcT = defined($matched) ? $matched : -1;
226 :     return $vcT;
227 :     }
228 :    
229 :     sub load_roles {
230 :     my($cgi,$html,$encoding,$abbrev_to_loc,$rolesI) = @_;
231 :    
232 :     my @roles = ();
233 :     foreach $_ (@$rolesI)
234 :     {
235 :     if ($_ =~ /^(\S+)\s+(\S.*\S)/)
236 :     {
237 :     my($abbrev,$role) = ($1,$2);
238 :     my $loc = &add_to_encoding($encoding,['role',$role]);
239 :     $abbrev_to_loc->{$abbrev} = $loc;
240 :     push(@roles,$role);
241 :     }
242 :     elsif ($_ =~ /\S/)
243 :     {
244 :     push(@$html,$cgi->h1("Invalid Role: $_"));
245 :     }
246 :     }
247 :     return @roles;
248 :     }
249 :    
250 :     sub add_to_encoding {
251 :     my($encoding,$val) = @_;
252 :    
253 :     my($mem,$nxt) = @$encoding;
254 :     $mem->[$nxt] = $val;
255 :     $encoding->[1]++;
256 :     return $nxt;
257 :     }
258 :    
259 :     sub load_definitions {
260 :     my($cgi,$html,$encoding,$abbrev_to_loc,$defI) = @_;
261 :    
262 :     my $rc = 1;
263 :     foreach my $def (@$defI)
264 :     {
265 :     if ($def =~ /^(\S+)\s+(\S.*\S)/)
266 :     {
267 :     my($abbrev,$bool) = ($1,$2);
268 :     my $loc = &parse_bool($bool,$encoding,$abbrev_to_loc);
269 :     $abbrev_to_loc->{$abbrev} = $loc;
270 :     }
271 :     elsif ($def =~ /\S/)
272 :     {
273 :     push(@$html,$cgi->h1("Invalid Definition: $def"));
274 :     $rc = 0;
275 :     }
276 :     }
277 :     return $rc;
278 :     }
279 :    
280 :     sub parse_rules {
281 :     my($cgi,$html,$encoding,$abbrev_to_loc,$rulesI) = @_;
282 :    
283 :     my @rules = ();
284 :     foreach $_ (@$rulesI)
285 :     {
286 :     my($boolexp,$variant_code,$loc);
287 :     if (($_ =~ /^\s*(\S+)\s+(\S.*\S)\s*$/) &&
288 :     (($variant_code,$boolexp) = ($1,$2)) &&
289 :     defined($loc = &parse_bool($boolexp,$encoding,$abbrev_to_loc)))
290 :     {
291 :     push(@rules,[$variant_code,[$encoding->[0],$loc]]);
292 :     }
293 :     elsif ($_ =~ /\S/)
294 :     {
295 :     push(@$html,$cgi->h1("Invalid rule: $_"));
296 :     }
297 :     }
298 :     return @rules;
299 :     }
300 :    
301 :     sub parse_bool {
302 :     my($s,$encoding,$abbrev_to_loc) = @_;
303 :    
304 :     my $input = $s;
305 :     my $abbrev;
306 :     foreach $abbrev (sort { length($b) <=> length($a) } keys(%$abbrev_to_loc))
307 :     {
308 :     my $loc = $abbrev_to_loc->{$abbrev};
309 :     my $abbrevQ = quotemeta $abbrev;
310 :     while ($s =~ s/(^|[\s\{,(])($abbrevQ)($|[\s\},)])/$1<$loc>$3/) {}
311 :     }
312 :     my $got = 0;
313 :     while ($s !~ /^\s*<\d+>\s*$/)
314 :     {
315 :     my $nxt = $encoding->[1];
316 :     if ($s =~ s/\(\s*(<\d+>)\s*\)/$1/)
317 :     {
318 :     $got = 1;
319 :     }
320 :     elsif ($s =~ s/not\s+<(\d+)>/<$nxt>/)
321 :     {
322 :     &add_to_encoding($encoding,["not",$1]);
323 :     $got = 1;
324 :     }
325 :     elsif ($s =~ s/<(\d+)>\s+and\s+<(\d+)>/<$nxt>/)
326 :     {
327 :     &add_to_encoding($encoding,["and",$1,$2]);
328 :     $got = 1;
329 :     }
330 :     elsif ($s =~ s/<(\d+)>\s+or\s+<(\d+)>/<$nxt>/)
331 :     {
332 :     &add_to_encoding($encoding,["or",$1,$2]);
333 :     $got = 1;
334 :     }
335 :     elsif ($s =~ s/<(\d+)>\s+->\s+<(\d+)>/<$nxt>/)
336 :     {
337 :     &add_to_encoding($encoding,["->",$1,$2]);
338 :     $got = 1;
339 :     }
340 :    
341 :     elsif ($s =~ s/(\d+)\s+of\s+\{\s*(<\d+>(,\s*<\d+>)*)\s*\}/<$nxt>/)
342 :     {
343 :     my $n = $1;
344 :     my $args = $2;
345 :     my @args = map { $_ =~ /<(\d+)>/; $1 } split(/,\s*/,$args);
346 :     &add_to_encoding($encoding,["of",$n,[@args]]);
347 :     $got = 1;
348 :     }
349 :     last if (! $got);
350 :     }
351 :     return ($s =~ /^\s*<(\d+)>\s*$/) ? $1 : undef;
352 :     }
353 :    
354 :    
355 :     sub gather_genes {
356 :     my($fig,$genome,$role,$role_to_pegs) = @_;
357 :    
358 :     return [sort { &FIG::by_fig_id($a,$b) }
359 :     grep { &FIG::genome_of($_) eq $genome }
360 :     @{$role_to_pegs->{$role}} ];
361 :     }
362 :    
363 :     sub is_rule_true {
364 :     my($rule,$relevant_genes) = @_;
365 :    
366 :     my($variant,$exp) = @$rule;
367 :     return &is_true_exp($exp,$relevant_genes) ? $variant : undef;
368 :     }
369 :    
370 :     sub is_true_exp {
371 :     my($bool,$relevant_genes) = @_;
372 :    
373 :     my($nodes,$root) = @$bool;
374 :     my $val = $nodes->[$root];
375 :     if (! ref $val)
376 :     {
377 :     return &is_true_exp([$nodes,$val],$relevant_genes);
378 :     }
379 :     else
380 :     {
381 :     my $op = $val->[0];
382 :    
383 :     if ($op eq 'role')
384 :     {
385 :     my $x;
386 :     return (($x = $relevant_genes->{$val->[1]}) && (@$x > 0)) ? 1 : 0;
387 :     }
388 :     elsif ($op eq "of")
389 :     {
390 :     my $truth_value;
391 :     my $count = 0;
392 :     foreach $truth_value (map { &is_true_exp([$nodes,$_],$relevant_genes) } @{$val->[2]})
393 :     {
394 :     if ($truth_value) { $count++ }
395 :     }
396 :     return $val->[1] <= $count;
397 :     }
398 :     elsif ($op eq "not")
399 :     {
400 :     return &is_true_exp([$nodes,$val->[1]],$relevant_genes) ? 0 : 1;
401 :     }
402 :     else
403 :     {
404 :     my $v1 = &is_true_exp([$nodes,$val->[1]],$relevant_genes);
405 :     my $v2 = &is_true_exp([$nodes,$val->[2]],$relevant_genes);
406 :     if ($op eq "and") { return $v1 && $v2 };
407 :     if ($op eq "or") { return $v1 || $v2 };
408 :     if ($op eq "->") { return ((not $v1) || $v2) }
409 :     else
410 :     {
411 :     print STDERR &Dumper($val);
412 :     die "invalid expression";
413 :     }
414 :     }
415 :     }
416 :     }
417 :    
418 :     sub print_bool {
419 :     my($bool) = @_;
420 :    
421 :     my $s = &printable_bool($bool);
422 :     print $s,"\n";
423 :     }
424 :    
425 :     sub printable_bool {
426 :     my($bool) = @_;
427 :    
428 :     my($nodes,$root) = @$bool;
429 :     my $val = $nodes->[$root];
430 :    
431 :     if (! ref $val)
432 :     {
433 :     return &printable_bool([$nodes,$val]);
434 :     }
435 :     else
436 :     {
437 :     my $op = $val->[0];
438 :    
439 :     if ($op eq 'role')
440 :     {
441 :     return $val->[1];
442 :     }
443 :     elsif ($op eq "of")
444 :     {
445 :     my @expanded_args = map { &printable_bool([$nodes,$_]) } @{$val->[2]};
446 :     my $args = join(',',@expanded_args);
447 :     return "$val->[1] of {$args}";
448 :     }
449 :     elsif ($op eq "not")
450 :     {
451 :     return "($op " . &printable_bool([$nodes,$val->[1]]) . ")";
452 :     }
453 :     else
454 :     {
455 :     return "(" . &printable_bool([$nodes,$val->[1]]) . " $op " . &printable_bool([$nodes,$val->[2]]) . ")";
456 :     }
457 :     }
458 :     }
459 :    
460 :     sub compute_genome_label
461 :     {
462 :     my($fig, $org) = @_;
463 :     my $label;
464 :    
465 :     my $gs = $fig->genus_species($org);
466 :     if ($fig->genome_domain($org) ne "Environmental Sample")
467 :     {
468 :     my $gc=$fig->number_of_contigs($org);
469 :     $label = "$gs ($org) [$gc contigs]";
470 :     }
471 :     else
472 :     {
473 :     $label = "$gs ($org)";
474 :     }
475 :     return $label;
476 :     }
477 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3