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

Annotation of /FigWebServices/wc.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download)

1 : overbeek 1.1 #!/usr/bin/env /vol/ross/FIGdisk/bin/run_perl
2 :    
3 :     BEGIN {
4 :     unshift @INC, qw(
5 :     /homes/overbeek/Ross/MakeCS.Kbase/bin
6 :     /homes/overbeek/Ross/JoseERmodel/Take2
7 :     /vol/ross/FIGdisk/dist/releases/dev/FigKernelPackages
8 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib
9 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/FigKernelPackages
10 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/WebApplication
11 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/FortyEight
12 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/PPO
13 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/RAST
14 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/MGRAST
15 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/SeedViewer
16 :     /vol/ross/FIGdisk/dist/releases/dev/common/lib/ModelSEED
17 :     /vol/ross/FIGdisk/dist/anon/common/lib
18 :     /vol/ross/FIGdisk/dist/anon/common/lib/FigKernelPackages
19 :     /vol/ross/FIGdisk/config
20 :    
21 :     );
22 :     }
23 :     use FIG;
24 :     my $fig = new FIG;
25 :    
26 :     use Data::Dumper;
27 :     use Carp;
28 :     use FIG_Config;
29 :     $ENV{'BLASTMAT'} = "/vol/ross/FIGdisk/BLASTMAT";
30 :     $ENV{'FIG_HOME'} = "/vol/ross/FIGdisk";
31 :     # end of tool_hdr
32 :     ########################################################################
33 :     use CGI;
34 :    
35 :    
36 :     if (-f "$FIG_Config::data/Global/why_down")
37 :     {
38 :     local $/;
39 :     open my $fh, "<$FIG_Config::data/Global/why_down";
40 :     my $down_msg = <$fh>;
41 :    
42 :     print CGI::header();
43 :     print CGI::head(CGI::title("SEED Server down"));
44 :     print CGI::start_body();
45 :     print CGI::h1("SEED Server down");
46 :     print CGI::p("The seed server is not currently running:");
47 :     print CGI::pre($down_msg);
48 :     print CGI::end_body();
49 :     exit;
50 :     }
51 :    
52 :     if ($FIG_Config::readonly)
53 :     {
54 :     CGI::param("user", undef);
55 :     }
56 :     ########################################################################
57 :     use CGI;
58 :    
59 :    
60 :     if (-f "$FIG_Config::data/Global/why_down")
61 :     {
62 :     local $/;
63 :     open my $fh, "<$FIG_Config::data/Global/why_down";
64 :     my $down_msg = <$fh>;
65 :    
66 :     print CGI::header();
67 :     print CGI::head(CGI::title("SEED Server down"));
68 :     print CGI::start_body();
69 :     print CGI::h1("SEED Server down");
70 :     print CGI::p("The seed server is not currently running:");
71 :     print CGI::pre($down_msg);
72 :     print CGI::end_body();
73 :     exit;
74 :     }
75 :    
76 :     if ($FIG_Config::readonly)
77 :     {
78 :     CGI::param("user", undef);
79 :     }
80 :     ########################################################################
81 :     # -*- perl -*-
82 :     #
83 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
84 :     # for Interpretations of Genomes. All Rights Reserved.
85 :     #
86 :     # This file is part of the SEED Toolkit.
87 :     #
88 :     # The SEED Toolkit is free software. You can redistribute
89 :     # it and/or modify it under the terms of the SEED Toolkit
90 :     # Public License.
91 :     #
92 :     # You should have received a copy of the SEED Toolkit Public License
93 :     # along with this program; if not write to the University of Chicago
94 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
95 :     # Genomes at veronika@thefig.info or download a copy from
96 :     # http://www.theseed.org/LICENSE.TXT.
97 :     #
98 :    
99 :     use URI::Escape; # uri_escape
100 :     use gjoseqlib;
101 :     use HTML;
102 :     use strict;
103 :     use CGI;
104 :     my $cgi = new CGI;
105 :     use SeedEnv;
106 :     use tree_utilities;
107 :     use CloseStrains;
108 :    
109 :     if (0) {
110 :     print $cgi->header;
111 :     my @params = $cgi->param;
112 :     print "<pre>\n";
113 :     foreach $_ (@params) {
114 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
115 :     }
116 :     print "\n",join('&',map { "$_=" . $cgi->param($_) } @params),"\n";
117 :     exit;
118 :     }
119 :    
120 :     my $html = [];
121 :    
122 :     my $node = $cgi->param('node');
123 :     my $family = $cgi->param('family');
124 :     my $ali = $cgi->param('alignment');
125 :     my $tree = $cgi->param('tree');
126 :     my $request = $cgi->param('request');
127 :     my $keywords = $cgi->param('keywords');
128 :     my $function = $cgi->param('function');
129 :     my $dataD = $cgi->param('dataD');
130 :     my $csD = "/homes/overbeek/Ross/MakeCS.Kbase/Data/CS";
131 :     my $dataDF = "$csD/$dataD";
132 :    
133 :     if ($request eq "show_otus")
134 :     {
135 :     &show_otus($cgi,$csD);
136 :     exit;
137 :     }
138 :     elsif (($request eq "show_options_for_otu") && $dataD)
139 :     {
140 :     $html = &CloseStrains::show_options_for_otu($cgi,$dataD);
141 :     }
142 :     elsif ($request eq "show_signatures")
143 :     {
144 :     &CloseStrains::show_signatures($cgi,$dataDF,$html);
145 :     }
146 :     elsif ($request eq "compute_sigs")
147 :     {
148 :     &CloseStrains::compute_signatures($cgi,$dataDF,$html);
149 :     }
150 :     elsif (($request eq "show_func") && $function)
151 :     {
152 :     $function =~ s/^\s+//;
153 :     $function =~ s/\s+$//;
154 :     &CloseStrains::show_func($cgi,$dataDF,$html,$function);
155 :     }
156 :     elsif (($request eq "show_family_pegs") && $family)
157 :     {
158 :     &CloseStrains::show_family_pegs($cgi,$dataDF,$html,$family);
159 :     }
160 :     elsif (($request eq "show_virulence_functions") && (-s "$dataDF/virulence.functions"))
161 :     {
162 :     &show_virulence_functions($cgi,$dataDF,$html);
163 :     }
164 :     elsif (($request eq 'show_indexed_funcs') && $keywords)
165 :     {
166 :     &show_indexed_funcs($cgi,$dataDF,$html,$keywords);
167 :     }
168 :     elsif (($request eq "show_ali_or_occurs_tree") && $ali)
169 :     {
170 :     &CloseStrains::show_ali($cgi,$dataDF); # NOTE: the alignment invokes Gary's alignment viewer,
171 :     # which prints the header, so we print everything in show_ali
172 :     exit;
173 :     }
174 :     elsif (($request eq "show_ali_or_occurs_tree") && $tree)
175 :     {
176 :     &CloseStrains::show_occurs_tree($cgi,$dataDF,$html);
177 :     }
178 :     elsif (($request eq "show_family_tree") && $family)
179 :     {
180 :     &CloseStrains::show_family_tree($cgi,$dataDF,$html,$family);
181 :     }
182 :     elsif (($request eq "show_node") && $node)
183 :     {
184 :     &show_changes($cgi,$dataDF,$html,$node);
185 :     }
186 :     elsif ($request eq "show_otu_tree")
187 :     {
188 :     &CloseStrains::show_otu_tree($cgi,$dataDF,$html,'families');
189 :     }
190 :     elsif ($request eq "show_adjacency")
191 :     {
192 :     &CloseStrains::show_otu_tree($cgi,$dataDF,$html,'adjacency');
193 :     }
194 :     elsif ($request eq "show_clusters")
195 :     {
196 :     &show_clusters($cgi,$dataDF,$html);
197 :     }
198 :     else
199 :     {
200 :     push(@$html,"<h1>Invalid request</h1>");
201 :     }
202 :     &HTML::show_page($cgi,$html);
203 :     exit;
204 :    
205 :     sub show_changes {
206 :     my($cgi,$dataDF,$html,$node) = @_;
207 :    
208 :     my $type = $cgi->param('type');
209 :     if ($type eq 'families')
210 :     {
211 :     &show_changes_families($cgi,$dataDF,$html,$node);
212 :     }
213 :     else
214 :     {
215 :     &show_changes_adjacency($cgi,$dataDF,$html,$node);
216 :     }
217 :     }
218 :    
219 :     sub show_changes_adjacency {
220 :     my($cgi,$dataDF,$html,$node) = @_;
221 :     $dataDF =~ /([^\/]+)$/;
222 :     my $dataD = $1;
223 :     my $col_hdrs = ['Family','Function','Ancestral','New','Compare'];
224 :     my @events = grep { $node eq $_->[1] }
225 :     map { ($_ =~ /(\S+)\t(\S+)\t(\d+):\S+\t(\d+):\S+\t(\d+)/) ? [$1,$2,$3,$4,$5] : () }
226 :     `cat $dataDF/placed.events`;
227 :     my %families = map { ($_->[2] => [$_->[3],$_->[4]])} @events;
228 :     my %pegs_needed = map { (($_->[2] => 1), ($_->[3] => 1),($_->[4] => 1)) } @events;
229 :     my %fam_peg = map { my $x;
230 :     (($_ =~ /^(\d+)\t\S+\t(\d+)\t\S+\t\S+\t(\S+)\t(\S+)/) &&
231 :     ($x = $families{$1}) && (($x->[0] eq $2) || ($x->[1] eq $2))) ? ("$1,$2" => $3) : () }
232 :     `cat $dataDF/adjacency.of.unique`;
233 :     my %peg_to_func = map { (($_ =~ /^([^t]+)\t([^\t]*)\t(\S+)/) && $pegs_needed{$1}) ? ($3 => $2) : () } `cut -f1,2,4 $dataDF/families.all`;
234 :     my @rows;
235 :     my $ancestor;
236 :     foreach my $event (@events)
237 :     {
238 :     my($anc,$node,$fam,$fam1,$fam2) = @$event;
239 :     $ancestor = $anc;
240 :     my $peg1 = $fam_peg{"$fam,$fam1"};
241 :     my $peg2 = $fam_peg{"$fam,$fam2"};
242 :     my $func = $peg_to_func{$peg1};
243 :     if ($peg1 && $peg2 && $func)
244 :     {
245 :     push(@rows,[&CloseStrains::show_fam_table_link($dataDF,$fam),
246 :     $func,
247 :     &CloseStrains::peg_link($peg1),
248 :     &CloseStrains::peg_link($peg2),
249 :     &compare_link([$peg1,$peg2])]);
250 :     }
251 :     }
252 :     push(@$html,&HTML::make_table($col_hdrs,\@rows,"Changes in Adjacency from $ancestor"));
253 :     }
254 :    
255 :    
256 :     sub show_changes_families {
257 :     my($cgi,$dataDF,$html,$node) = @_;
258 :    
259 :     $dataDF =~ /([^\/]+)$/;
260 :     my $dataD = $1;
261 :    
262 :     my %func = map { ($_ =~ /^(\d+)\t(\S[^\t]*\S)/) ? ($1 => $2) : () } `cut -f1,2 $dataDF/families.all`;
263 :     my $col_hdrs = ['Show Where','Show PEGs','Family','Function','Clusters','Coupling'];
264 :     my @tmp = grep { (($_ =~ /^\S+\t(\S+)/) && ($1 eq $node)) }
265 :     `cat /$dataDF/where.shifts.occurred`;
266 :     my @tabG = sort { ($a->[4] cmp $b->[4]) or ($a->[3] <=> $b->[3]) }
267 :     map { ($_ =~ /^(\S+)\t\S+\t(\S+)\t0\t1/) ? [&CloseStrains::show_fam_links($dataDF,$2),$1,$2,$func{$2}] : () }
268 :     @tmp;
269 :     # tabG entries are [linkT,linkP,ancestor,fam,func]
270 :    
271 :     # try to pick up the ancestor node from the first entry in @tabG
272 :     # If you cannot get it, try to take it from @tabL
273 :     my $anc = (@tabG > 0) ? $tabG[0]->[-3] : undef;
274 :     foreach $_ (@tabG) { splice(@$_,2,1) } ### get rid of ancestor
275 :     ## tabG entries are [linkT,linkP,fam,func]
276 :    
277 :     my @tabL = sort { ($a->[4] cmp $b->[4]) or ($a->[3] <=> $b->[3]) }
278 :     map { ($_ =~ /^(\S+)\t\S+\t(\S+)\t1\t0/) ? [&CloseStrains::show_fam_links($dataDF,$2),$1,$2,$func{$2}] : () }
279 :     @tmp;
280 :     if (! $anc)
281 :     {
282 :     $anc = (@tabL > 0) ? $tabL[0]->[-3] : '';
283 :     }
284 :     foreach $_ (@tabL) { splice(@$_,2,1) } ### get rid of ancestor
285 :    
286 :     ## @tabG and @tabL are of the form [link-to-tree,link-to-peg-display,family,function]]
287 :     ## we now add coupling data.
288 :    
289 :     my $with_couplingL = &build_table(\@tabL,$dataDF);
290 :     my $with_couplingG = &build_table(\@tabG,$dataDF);
291 :    
292 :     push(@$html,&HTML::make_table($col_hdrs,$with_couplingG,"Families Gained from Ancestor $anc"),$cgi->hr,"\n");
293 :     push(@$html,&HTML::make_table($col_hdrs,$with_couplingL,"Families Lost from Ancestor $anc"),$cgi->hr,"\n");
294 :     }
295 :    
296 :    
297 :     sub build_table {
298 :     my($tab,$dataDF) = @_;
299 :     $dataDF =~ /([^\/]+)$/;
300 :     my $dataD = $1;
301 :    
302 :     my %famH = map { ($_->[-2] => 1) } @$tab;
303 :     my %fam_to_func = map { ($_->[2] => $_->[3]) } @$tab;
304 :     my $coupledH = &CloseStrains::coupling_data($dataDF,\%famH);
305 :     my @with_coupling;
306 :     foreach my $tuple (@$tab)
307 :     {
308 :     my($link1,$link2,$family,$function) = @$tuple;
309 :     $tuple->[3] = &CloseStrains::show_func_link($dataD,$function);
310 :     my($cluster_link,$coupled_html) = &CloseStrains::cluster_link_and_cluster_html($family,$coupledH,\%fam_to_func,$dataD);
311 :     $tuple->[4] = $cluster_link;
312 :     $tuple->[5] = $coupled_html;
313 :     push(@with_coupling,$tuple);
314 :     }
315 :     return \@with_coupling;
316 :     }
317 :    
318 :    
319 :    
320 :     sub show_indexed_funcs {
321 :     my($cgi,$dataDF,$html,$keywords) = @_;
322 :    
323 :     $dataDF =~ /([^\/]+)$/;
324 :     my $dataD = $1;
325 :    
326 :     my $functions_in_fams = &functions_in_at_least_one_family($dataDF);
327 :     # $keywords = "$dataD " . $keywords; ### tell the user to add it,if necessary
328 :    
329 :     my %funcs_to_show;
330 :    
331 :     foreach my $func (`svr_sphinx_indexing -k \'$keywords\' | cut -f1 | svr_function_of | cut -f2`)
332 :     {
333 :     chomp $func;
334 :     $func =~ s/\s*\#.*$//;
335 :     if ($functions_in_fams->{$func})
336 :     {
337 :     $funcs_to_show{$func}++;
338 :     }
339 :     }
340 :     my @funcs = sort { $funcs_to_show{$b} <=> $funcs_to_show{$a} } keys(%funcs_to_show);
341 :     if (@funcs == 0)
342 :     {
343 :     push(@$html,"<h1>Sorry, no functions matched</h1>\n");
344 :     }
345 :     else
346 :     {
347 :     my @links = map { [&CloseStrains::show_func_link($dataD,$_)] } @funcs;
348 :     push(@$html,&HTML::make_table(['Possible Functions'],\@links,"Possible functions - Select to find nodes where shifts occurred"));
349 :     }
350 :     }
351 :    
352 :     sub show_virulence_functions {
353 :     my($cgi,$dataDF,$html) = @_;
354 :    
355 :     $dataDF =~ /([^\/]+)$/;
356 :     my $dataD = $1;
357 :    
358 :     my $functions_in_fams = &functions_in_at_least_one_family($dataDF);
359 :     my @virulence_functions = map { chomp; $functions_in_fams->{$_} ? $_ : () } `cat $dataDF/virulence.functions`;
360 :     my @links = map { [&CloseStrains::show_func_link($dataD,$_)] } sort @virulence_functions;
361 :     push(@$html,&HTML::make_table(['Function Sometimes Associated with Virulence'],
362 :     \@links,
363 :     'Functions Known to Be Associated with Virulence in Some Organisms'));
364 :     }
365 :     sub functions_in_at_least_one_family {
366 :     my($dataDF) = @_;
367 :    
368 :     my %functions_in_fams = map { chomp; ($_ => 1) } `cut -f2 $dataDF/families.all`;
369 :     return \%functions_in_fams;
370 :     }
371 :    
372 :     sub subsystems_of {
373 :     my($fig,$reaction_to_roles,$reaction) = @_;
374 :    
375 :     my $roles_and_pegs = $reaction_to_roles->{$reaction};
376 :     my @roles = map { my $x = $_; $x =~ s/^[^:]+://; $x } @{$reaction_to_roles->{$reaction}};
377 :     my $printable_roles = "";
378 :     if (@roles > 0)
379 :     {
380 :     my %tmp = map { $_ =~ /^([^:]+):(\S.*\S)/; ($2 => $1) } @$roles_and_pegs;
381 :     my @tmp = map { &CloseStrains::peg_link($tmp{$_}) . "<br>" . $_ } sort keys(%tmp);
382 :     $printable_roles = join(",",@tmp);
383 :     }
384 :     my %subsys;
385 :     foreach my $role (@roles)
386 :     {
387 :     foreach my $s ($fig->role_to_subsystems($role))
388 :     {
389 :     $subsys{$s} = 1;
390 :     }
391 :     }
392 :     return join("\t",sort keys(%subsys)) . "<br>" . $printable_roles;
393 :     }
394 :    
395 :    
396 :     sub show_otus {
397 :     my($cgi,$datadir) = @_;
398 :    
399 :     print $cgi->header;
400 :     if (opendir(GENERA,$csD))
401 :     {
402 :     my @genera = grep { $_ !~ /^\./ } readdir(GENERA);
403 :     closedir(GENERA);
404 :     print "<h1>What Changed?</h1>\n";
405 :     print "<h2><a target=_blank href=\"http://bioseed.mcs.anl.gov/~overbeek/what_changed.html\">Getting Started: a short Tutorial</a></h2>\n";
406 :     print "<h2>Genera Available</h2>\n";
407 :     foreach my $g (sort @genera)
408 :     {
409 :     print "<h3><a target=_blank href=http://bioseed.mcs.anl.gov/ross/FIG/wc.cgi?request=show_options_for_otu&dataD=$g>$g</a>\n";
410 :     }
411 :     }
412 :     else
413 :     {
414 :     print "<h1>The dataD parameter is invalid\n";
415 :     }
416 :     }
417 :    
418 :     sub compare_link {
419 :     my($pegs) = @_;
420 :     my @genomes = map { ($_ =~ /^fig\|(\d+\.\d+)/) ? $1 : () } @$pegs;
421 :     my $args = join("&",map { "show_genome=$_" } @genomes);
422 :     return "<a target=_blank href=http://pubseed.theseed.org/seedviewer.cgi?page=Annotation&feature=" .
423 :     $pegs->[0] . "&$args>Compare Regions</a>";
424 :     }
425 :    
426 :    
427 :     sub virulence_functions_link {
428 :     my($cgi,$dataDF) = @_;
429 :    
430 :     if ((-s "$dataDF/virulence.functions") && ($dataDF =~ /([^\/]+)$/))
431 :     {
432 :     my $dataDQ = uri_escape($1);
433 :     return "<a target=_blank href=http://bioseed.mcs.anl.gov/ross/FIG/wc.cgi?request=show_virulence_functions&dataD=$dataDQ>Some Posssible Functions Associated with Virulence</a>";
434 :     }
435 :     return '';
436 :     }
437 :    
438 :     sub show_clusters {
439 :     my($cgi,$dataDF,$html) = @_;
440 :    
441 :     my $families = $cgi->param('families');
442 :     my @families = split(/,/,$families);
443 :     my %families = map { $_ => 1 } @families;
444 :     my %genome_names = map { ($_ =~ /^(\S+)\t(\S.*\S)/) ? ($1 => $2) : () } `cat $dataDF/genome.names`;
445 :     my @genome_pegN_fam_func = sort { ($a->[0] <=> $b->[0]) or ($a->[1] <=> $b->[1]) }
446 :     map { (($_ =~ /^(\S+)\t([^\t]*)\t[^\t]*\tfig\|(\d+\.\d+)\.peg\.(\d+)/) && $families{$1}) ?
447 :     [$3,$4,$1,$2] : ()
448 :     } `cat $dataDF/families.all`;
449 :     push(@$html,$cgi->h1('Relevant Clusters'));
450 :     my $col_hdrs = ['Family','Function','PEG'];
451 :     my $last = shift @genome_pegN_fam_func;
452 :     while ($last)
453 :     {
454 :     my $last_g = $last->[0];
455 :     my $last_pegN = $last->[1];
456 :     my @set;
457 :     while ($last && ($last_g == $last->[0]) && &close($last_pegN,$last->[1]))
458 :     {
459 :     $last_pegN = $last->[1];
460 :     push(@set,[$last->[2],$last->[3],&CloseStrains::peg_link("fig|" . $last_g . ".peg." . $last_pegN)]);
461 :     $last = shift @genome_pegN_fam_func;
462 :     }
463 :     if (@set > 1)
464 :     {
465 :     push(@$html,&HTML::make_table($col_hdrs,\@set,"Cluster for $last_g: $genome_names{$last_g}"));
466 :     push(@$html,"<hr><br><br>\n");
467 :     }
468 :     }
469 :     }
470 :    
471 :     sub close {
472 :     my($pegN1,$pegN2) = @_;
473 :    
474 :     return abs($pegN2 - $pegN1) <= 7;
475 :     }
476 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3