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

Annotation of /FigWebServices/check_subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 : olson 1.10 #
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 : overbeek 1.1
20 :     use FIG;
21 :     my $fig = new FIG;
22 :    
23 : olson 1.23 use URI::Escape;
24 : overbeek 1.1 use Subsystem;
25 :    
26 :     use HTML;
27 :     use strict;
28 :    
29 :     use CGI;
30 :     my $cgi = new CGI;
31 :    
32 :     if (0)
33 :     {
34 :     my $VAR1;
35 :     eval(join("",`cat /tmp/check_ssa_parms`));
36 :     $cgi = $VAR1;
37 :     # print STDERR &Dumper($cgi);
38 :     }
39 :    
40 :     if (0)
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 (0)
51 :     {
52 :     if (open(TMP,">/tmp/check_ssa_parms"))
53 :     {
54 :     print TMP &Dumper($cgi);
55 :     close(TMP);
56 :     }
57 :     }
58 :     exit;
59 :     }
60 :     my($genome);
61 :    
62 :     my $html = [];
63 :     my $subsys = $cgi->param('subsystem');
64 : overbeek 1.19 my $user = $cgi->param('user');
65 :     $user =~ s/master://;
66 :    
67 : overbeek 1.1 if (! $subsys)
68 :     {
69 : overbeek 1.19 if ($cgi->param('request') eq "check_summary")
70 : overbeek 1.1 {
71 : overbeek 1.19 &check_summary($fig,$cgi,$html,$user);
72 : overbeek 1.1 }
73 :     else
74 :     {
75 : overbeek 1.19 my @ssa = &existing_subsystem_annotations;
76 :    
77 :     if (@ssa > 0)
78 :     {
79 :     &format_ssa_table($cgi,$html,\@ssa);
80 :     }
81 :     else
82 :     {
83 :     push(@$html,$cgi->h1('Sorry, no subsystems defined'));
84 :     }
85 : overbeek 1.1 }
86 :     }
87 :     elsif ($subsys && ($cgi->param('request') eq "check_ssa"))
88 :     {
89 :     &check_subsystem($cgi,$fig,$html,$subsys);
90 :     }
91 :     &HTML::show_page($cgi,$html);
92 :    
93 :     sub format_ssa_table {
94 :     my($cgi,$html,$ssaP) = @_;
95 :    
96 : overbeek 1.2 my $user = $cgi->param('user');
97 :     $user = $user ? $user : "";
98 : overbeek 1.1 push(@$html, $cgi->start_form(-action => "check_subsys.cgi",
99 :     -method => 'post'),
100 :     $cgi->hidden(-name => 'request', -value => 'check_ssa', -override => 1),
101 : overbeek 1.2 $cgi->hidden(-name => 'user', -value => "$user", -override => 1),
102 : overbeek 1.1 $cgi->scrolling_list( -name => 'subsystem',
103 :     -values => [ map { $_->[0] } @$ssaP ],
104 :     -size => 10
105 :     ),
106 :     $cgi->br,
107 :     $cgi->submit( 'Pick One' ),
108 :     $cgi->end_form
109 :     );
110 :     }
111 :    
112 :     sub existing_subsystem_annotations {
113 :     my($ssa,$name);
114 :     my @ssa = ();
115 :     if (opendir(SSA,"$FIG_Config::data/Subsystems"))
116 :     {
117 :     @ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/[ \/]/_/g; [$name,&curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA);
118 :     closedir(SSA);
119 :     }
120 :     return sort { $a->[0] cmp $b->[0] } @ssa;
121 :     }
122 :    
123 :     sub curator {
124 :     my($ssa) = @_;
125 :     my($who) = "";
126 :    
127 :     if (open(DATA,"<$FIG_Config::data/Subsystems/$ssa/curation.log"))
128 :     {
129 :     $_ = <DATA>;
130 :     if ($_ =~ /^\d+\t(\S+)\s+started/)
131 :     {
132 :     $who = $1;
133 :     }
134 :     close(DATA);
135 :     }
136 :     return $who;
137 :     }
138 :    
139 :     sub check_subsystem {
140 :     my($cgi,$fig,$html,$subsys) = @_;
141 : redwards 1.4 my($col_hdrs1,$col_hdrs2,$tab1,$tab2,$x);
142 : overbeek 1.1
143 : redwards 1.4 my $user=$cgi->param('user');
144 : overbeek 1.21 my @raw_output = &get_check_data($cgi,$subsys,$fig);
145 : overbeek 1.12
146 :     # my @raw_output = &FIG::run_gathering_output("$FIG_Config::bin/check_subsystems", $subsys);
147 : overbeek 1.11 # warn "Got raw output @raw_output\n";
148 : olson 1.9 my @checked = map { chop; [split(/\t/,$_)] } @raw_output;
149 : overbeek 1.13
150 : redwards 1.4 # RAE: it only makes sense to have Assign Role in column 1, so I duplicate this instead of leaving the column empty. Blah.
151 : redwards 1.6 $col_hdrs1 = ["PEG","Function","Role","Assign Role","Other Subsystems","Genome"];
152 : redwards 1.4 $col_hdrs2 = ["PEG","Function","Role","Other Subsystems","Genome"];
153 : overbeek 1.1 $tab1 = [];
154 :     $tab2 = [];
155 :    
156 :     foreach $x (@checked)
157 :     {
158 : overbeek 1.26 if ($x->[0] =~ /^(mismatch|left-out)/)
159 : overbeek 1.1 {
160 : overbeek 1.26 my($code,$peg,$func,$role,$gs) = @$x;
161 : overbeek 1.25 $role =~ s/\s+$//;
162 : overbeek 1.16 next if (! $fig->is_real_feature($peg));
163 : overbeek 1.24 next if ($func ne scalar &stripped_function_of($fig,$peg));
164 : overbeek 1.22 next if (($code eq "mismatch") && (&still_left_out($fig,$peg,$subsys)));
165 : overbeek 1.25 next if (($code eq "mismatch") && ($func eq $role));
166 : overbeek 1.17 next if (($code eq "left-out") && (! &still_left_out($fig,$peg,$subsys)));
167 : overbeek 1.16
168 : overbeek 1.12 #RAE added the other subsystems column to the table
169 :     my $othersubsys='';
170 :     if (my @otherss = $fig->subsystems_for_peg($peg))
171 :     {
172 :     foreach my $ssr (@otherss)
173 :     {
174 :     next if ($$ssr[0] eq $subsys);
175 : olson 1.23 $othersubsys .= $cgi->a({href => "subsys.cgi?user=$user&ssa_name=" . uri_escape($$ssr[0]) . "&request=show_ssa"}, $$ssr[0]) . "<br\n";
176 : overbeek 1.12 }
177 :     }
178 :     my $link = &HTML::fid_link($cgi,$peg);
179 :     my $checkbox=$cgi->checkbox(-name=>"checked", -label=>'', -value=>"to=$peg,from=$role");
180 :     if ($code eq "mismatch")
181 :     {
182 :     push(@$tab1,[$link,$func,$role,$checkbox,$othersubsys,$gs]);
183 :     }
184 :     elsif ($code eq 'left-out')
185 :     {
186 :     push(@$tab2,[$link,$func,$role,$othersubsys,$gs]);
187 :     }
188 : overbeek 1.1 }
189 :     }
190 : redwards 1.4
191 :     # RAE addd the form controls
192 :     push(@$html, $cgi->start_form( -method => 'post', -action => 'fid_checked.cgi', -name => 'fid_checked'), $cgi->hidden(-name => 'user', -value => $user));
193 :     push(@$html,&HTML::make_table($col_hdrs1,$tab1,"PEGs IN Subsystem with MISMATCHING Functions"));
194 : redwards 1.5
195 : redwards 1.6 push(@$html, $cgi->br, &HTML::java_buttons("fid_checked", "checked"), $cgi->br);
196 : redwards 1.7 push(@$html, $cgi->submit(-name=>'batch_assign', -label=>"Assign Roles to Selected PEGs"));
197 : overbeek 1.2 push(@$html,$cgi->hr,$cgi->br,$cgi->br);
198 :    
199 : redwards 1.4 push(@$html,&HTML::make_table($col_hdrs2,$tab2,"PEGs NOT in Subsystem with MATCHING Functions"));
200 : overbeek 1.8 push(@$html,$cgi->end_form);
201 : overbeek 1.13
202 :     my $col_hdrs3 = ['Genome','Genus and Species','Possible Variant Codes','Detected Roles'];
203 :     my $tab3 = [];
204 : overbeek 1.16
205 :     my $sobj = $fig->get_subsystem($subsys);
206 :     my %genomes_in_sub = map { $_ => 1 } $sobj->get_genomes;
207 :     my @to_add = grep { ($_->[1] eq 'maybe-add') && (! $genomes_in_sub{$_->[4]}) } @checked;
208 : overbeek 1.13
209 :     my($entry,$vcodes,$genome,$gs,@roles);
210 : overbeek 1.15 foreach $entry (sort { $a->[5] cmp $b->[5] } @to_add)
211 : overbeek 1.13 {
212 :     (undef,undef,undef,$vcodes,$genome,$gs,@roles) = @$entry;
213 :     push(@$tab3,[$genome,$gs,$vcodes,join("<br>",@roles)]);
214 :     }
215 :     push(@$html,&HTML::make_table($col_hdrs3,$tab3,"Genomes that Should Be Considered For Addition"));
216 :     }
217 :    
218 : overbeek 1.12 sub get_check_data {
219 : overbeek 1.21 my($cgi,$subsys,$fig) = @_;
220 : overbeek 1.12 my @raw_output;
221 :    
222 :     if ($cgi->param('fast') && (-e "$FIG_Config::data/Subsystems/$subsys/warnings"))
223 :     {
224 : overbeek 1.21 @raw_output = $fig->file_read("$FIG_Config::data/Subsystems/$subsys/warnings");
225 : overbeek 1.12 }
226 :     else
227 :     {
228 :     @raw_output = &FIG::run_gathering_output("$FIG_Config::bin/check_subsystems", $subsys);
229 :     # warn "Got raw output @raw_output\n";
230 :     }
231 :     return @raw_output;
232 :     }
233 :    
234 : overbeek 1.17 sub still_left_out {
235 : overbeek 1.18 my($fig,$peg,$sub) = @_;
236 : overbeek 1.17
237 :     my @subs = $fig->peg_to_subsystems($peg);
238 :     my $i;
239 :     for ($i=0; ($i < @subs) && ($sub ne $subs[$i]); $i++) {}
240 :     return ($i == @subs);
241 :     }
242 : overbeek 1.19
243 :     sub check_summary {
244 :     my($fig,$cgi,$html,$user) = @_;
245 :    
246 :     my $col_hdrs = ["Subsystem","Last Check Computed","Mismatching Entries","Missing Entries","Genomes to Add"];
247 :     my $tab = [];
248 :     my @subs = ();
249 :     foreach my $sub ($fig->all_subsystems)
250 :     {
251 :     my $curr = $fig->subsystem_curator($sub);
252 :     $curr =~ s/^master://;
253 :     if (($curr eq $user) &&
254 :     (-e "$FIG_Config::data/Subsystems/$sub/warnings"))
255 :     {
256 :     push(@subs,$sub);
257 :     }
258 :     }
259 :     foreach my $sub (@subs)
260 :     {
261 :     my $ts = localtime($^T - ((-M "$FIG_Config::data/Subsystems/$sub/warnings") * 24 * 60 * 60));
262 : overbeek 1.21 my @tmp = $fig->file_read("$FIG_Config::data/Subsystems/$sub/warnings");
263 : overbeek 1.19 my @mismatches = grep { ($_ =~ /mismatch\t(\S+)\t([^\t]+)/) } @tmp;
264 :     my $mismatchesN = (@mismatches > 0) ? @mismatches : 0;
265 :     my @left_out = grep { ($_ =~ /left-out\t(\S+)\t([^\t]+)/) } @tmp;
266 :     my $left_outN = (@left_out > 0) ? @left_out : 0;
267 :     my @maybe_add = grep { ($_ =~ /maybe-add\t[^\t]+\t[^\t]+\t(\d+\.\d+)/) } @tmp;
268 :     my $maybe_addN = (@maybe_add > 0) ? @maybe_add : 0;
269 : overbeek 1.20 push(@$tab,[&sub_link($cgi,$sub,$user),$ts,$mismatchesN,$left_outN,$maybe_addN]);
270 : overbeek 1.19 }
271 :     push(@$html,$cgi->h3("Note that the following statistics do not take into account actions since last check"),
272 :     &HTML::make_table($col_hdrs,$tab,"Summary of Possible Things to Check"));
273 :     }
274 : overbeek 1.20
275 :     sub sub_link {
276 :     my($cgi,$sub,$user) = @_;
277 : olson 1.23 my $esc_sub = uri_escape($sub);
278 :     my $url = &FIG::cgi_url . "/subsys.cgi?request=show_ssa&user=master:$user&ssa_name=$esc_sub&can_alter=1&check=1";
279 : overbeek 1.20 my $target = "window$$";
280 :     return "<a href=$url target=$target>$sub</a>";
281 :     }
282 : overbeek 1.24
283 :     sub stripped_function_of {
284 :     my($fig,$peg) = @_;
285 :    
286 :     my $func = $fig->function_of($peg);
287 :     $func =~ s/\s*\#.*$//;
288 :     return $func;
289 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3