Parent Directory
|
Revision Log
Revision 1.2 - (view) (download)
1 : | dejongh | 1.1 | # -*- perl -*- |
2 : | olson | 1.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 : | dejongh | 1.1 | ### subsys_hope.cgi ### |
20 : | # | ||
21 : | # Copy of subsys.cgi from early August 2005 with option added to view | ||
22 : | # functional roles with EC's in the context of relevant KEGG maps. | ||
23 : | # | ||
24 : | # Author: Kevin Formsma | ||
25 : | # Contact: kevin.formsma@hope.edu | ||
26 : | # Hope College, Summer Research 2005 REU | ||
27 : | ################### | ||
28 : | |||
29 : | use FIG; | ||
30 : | use FIGjs; # mouseover() | ||
31 : | use KGMLData; # to parse relations in KEGG maps | ||
32 : | my $fig = new FIG; | ||
33 : | |||
34 : | use Subsystem; | ||
35 : | |||
36 : | use URI::Escape; # uri_escape() | ||
37 : | use HTML; | ||
38 : | use strict; | ||
39 : | use tree_utilities; | ||
40 : | |||
41 : | use CGI; | ||
42 : | |||
43 : | my $cgi = new CGI; | ||
44 : | if (0) | ||
45 : | { | ||
46 : | my $VAR1; | ||
47 : | eval(join("",`cat /tmp/ssa_parms`)); | ||
48 : | $cgi = $VAR1; | ||
49 : | # print STDERR &Dumper($cgi); | ||
50 : | } | ||
51 : | |||
52 : | if (0) | ||
53 : | { | ||
54 : | print $cgi->header; | ||
55 : | my @params = $cgi->param; | ||
56 : | print "<pre>\n"; | ||
57 : | foreach $_ (@params) | ||
58 : | { | ||
59 : | print "$_\t:",join(",",$cgi->param($_)),":\n"; | ||
60 : | } | ||
61 : | |||
62 : | if (0) | ||
63 : | { | ||
64 : | if (open(TMP,">/tmp/ssa_parms")) | ||
65 : | { | ||
66 : | print TMP &Dumper($cgi); | ||
67 : | close(TMP); | ||
68 : | } | ||
69 : | } | ||
70 : | exit; | ||
71 : | } | ||
72 : | |||
73 : | # request to display the phylogenetic tree | ||
74 : | # | ||
75 : | my $request = $cgi->param("request"); | ||
76 : | if ($request && ($request eq "show_tree")) | ||
77 : | { | ||
78 : | print $cgi->header; | ||
79 : | &show_tree; | ||
80 : | exit; | ||
81 : | } | ||
82 : | |||
83 : | my $html = []; | ||
84 : | push @$html, "<TITLE>SEED Subsystems</TITLE>\n"; # RAE: every page deserves a title | ||
85 : | |||
86 : | my $user = $cgi->param('user'); | ||
87 : | $fig->set_user($user); | ||
88 : | |||
89 : | if ($cgi->param('resynch_peg_connections') && (my $ssa = $cgi->param('ssa_name'))) | ||
90 : | { | ||
91 : | my $subsystem = new Subsystem($ssa,$fig,0); | ||
92 : | $subsystem->db_sync(0); | ||
93 : | undef $subsystem; | ||
94 : | &one_cycle($fig,$cgi,$html); | ||
95 : | } | ||
96 : | elsif ($user && ($cgi->param("extend_with_billogix"))) | ||
97 : | { | ||
98 : | # | ||
99 : | # Start a bg task to extend the subsystem. | ||
100 : | # | ||
101 : | |||
102 : | my $ssa = $cgi->param('ssa_name'); | ||
103 : | |||
104 : | my $user = $cgi->param('user'); | ||
105 : | |||
106 : | my $sub = $fig->get_subsystem($ssa); | ||
107 : | |||
108 : | if ($sub && ($user eq $sub->get_curator)) | ||
109 : | { | ||
110 : | # | ||
111 : | # See if there's already an extend job running. | ||
112 : | # | ||
113 : | |||
114 : | my $curpid = $sub->get_current_extend_pid(); | ||
115 : | if ($curpid) | ||
116 : | { | ||
117 : | warn "Found current pid $curpid\n"; | ||
118 : | my $j = $fig->get_job($curpid); | ||
119 : | warn "job is $j\n"; | ||
120 : | warn "running is ", $j->running(), "\n" if $j; | ||
121 : | if ($j && $j->running()) | ||
122 : | { | ||
123 : | push(@$html, "Subsystem extension is already running as job number $curpid. <br>", | ||
124 : | "Click <a href=\"seed_ctl.cgi?user=$user\">here</a> to see currently running jobs and their status"); | ||
125 : | last; | ||
126 : | } | ||
127 : | } | ||
128 : | |||
129 : | my $pid = $fig->run_in_background(sub {$sub->extend_with_billogix($user);}); | ||
130 : | |||
131 : | push(@$html, | ||
132 : | "Subsystem extension started as background job number $pid <br>\n", | ||
133 : | "Click <a href=\"seed_ctl.cgi?user=$user\">here</a> to see currently running jobs and their status"); | ||
134 : | |||
135 : | $sub->set_current_extend_pid($pid); | ||
136 : | } | ||
137 : | else | ||
138 : | { | ||
139 : | push(@$html, "Subsystem '$ssa' could not be loaded"); | ||
140 : | } | ||
141 : | &HTML::show_page($cgi, $html); | ||
142 : | exit; | ||
143 : | } | ||
144 : | else | ||
145 : | { | ||
146 : | $request = defined($request) ? $request : ""; | ||
147 : | |||
148 : | if (($request eq "reset") && $user) | ||
149 : | { | ||
150 : | &reset_ssa($fig,$cgi,$html); # allow user to go back to a previous version of the ss | ||
151 : | } | ||
152 : | elsif (($request eq "reset_to") && $user) | ||
153 : | { | ||
154 : | &reset_ssa_to($fig,$cgi,$html); # this actually resets to the previous version | ||
155 : | &one_cycle($fig,$cgi,$html); | ||
156 : | } | ||
157 : | elsif (($request eq "make_exchangable") && $user) | ||
158 : | { | ||
159 : | &make_exchangable($fig,$cgi,$html); | ||
160 : | &show_initial($fig,$cgi,$html); | ||
161 : | } | ||
162 : | elsif (($request eq "make_unexchangable") && $user) | ||
163 : | { | ||
164 : | &make_unexchangable($fig,$cgi,$html); | ||
165 : | &show_initial($fig,$cgi,$html); | ||
166 : | } | ||
167 : | elsif ($request eq "show_ssa") | ||
168 : | { | ||
169 : | if ($_ = $cgi->param('check')) | ||
170 : | { | ||
171 : | push(@$html,$cgi->h1('CHECKING SUBSYSTEM'), | ||
172 : | &check_ssa($fig,$cgi), | ||
173 : | $cgi->hr | ||
174 : | ); | ||
175 : | } | ||
176 : | &one_cycle($fig,$cgi,$html); | ||
177 : | } | ||
178 : | # | ||
179 : | # Note that this is a little different; I added another submit button | ||
180 : | # to the delete_or_export_ssa form, so have to distinguish between them | ||
181 : | # here based on $cgi->param('delete_export') - the original button, | ||
182 : | # or $cgi->param('publish') - the new one. | ||
183 : | # | ||
184 : | elsif (($request eq "delete_or_export_ssa") && $user && | ||
185 : | defined($cgi->param('delete_export'))) | ||
186 : | { | ||
187 : | my($ssa,$exported); | ||
188 : | $exported = 0; | ||
189 : | foreach $ssa ($cgi->param('export')) | ||
190 : | { | ||
191 : | if (! $exported) | ||
192 : | { | ||
193 : | print $cgi->header; | ||
194 : | print "<pre>\n"; | ||
195 : | } | ||
196 : | &export($fig,$cgi,$ssa); | ||
197 : | $exported = 1; | ||
198 : | } | ||
199 : | |||
200 : | foreach $ssa ($cgi->param('export_assignments')) | ||
201 : | { | ||
202 : | &export_assignments($fig,$cgi,$ssa); | ||
203 : | } | ||
204 : | |||
205 : | foreach $ssa ($cgi->param('delete')) | ||
206 : | { | ||
207 : | my $sub = $fig->get_subsystem($ssa); | ||
208 : | $sub->delete_indices(); | ||
209 : | |||
210 : | my $cmd = "rm -rf '$FIG_Config::data/Subsystems/$ssa'"; | ||
211 : | my $rc = system $cmd; | ||
212 : | } | ||
213 : | |||
214 : | if (! $exported) | ||
215 : | { | ||
216 : | &show_initial($fig,$cgi,$html); | ||
217 : | } | ||
218 : | else | ||
219 : | { | ||
220 : | print "</pre>\n"; | ||
221 : | exit; | ||
222 : | } | ||
223 : | } | ||
224 : | elsif (($request eq "delete_or_export_ssa") && $user && | ||
225 : | defined($cgi->param('publish'))) | ||
226 : | { | ||
227 : | my($ssa,$exported); | ||
228 : | my($ch) = $fig->get_clearinghouse(); | ||
229 : | |||
230 : | print $cgi->header; | ||
231 : | |||
232 : | if (!defined($ch)) | ||
233 : | { | ||
234 : | print "cannot publish: clearinghouse not available\n"; | ||
235 : | exit; | ||
236 : | } | ||
237 : | |||
238 : | foreach $ssa ($cgi->param('publish_to_clearinghouse')) | ||
239 : | { | ||
240 : | print "<h2>Publishing $ssa to clearinghouse...</h2>\n"; | ||
241 : | $| = 1; | ||
242 : | print "<pre>\n"; | ||
243 : | my $res = $fig->publish_subsystem_to_clearinghouse($ssa); | ||
244 : | print "</pre>\n"; | ||
245 : | if ($res) | ||
246 : | { | ||
247 : | print "Published <i>$ssa </i> to clearinghouse<br>\n"; | ||
248 : | } | ||
249 : | else | ||
250 : | { | ||
251 : | print "<b>Failed</b> to publish <i>$ssa</i> to clearinghouse<br>\n"; | ||
252 : | } | ||
253 : | } | ||
254 : | exit; | ||
255 : | } | ||
256 : | elsif (($request eq "delete_or_export_ssa") && $user && | ||
257 : | defined($cgi->param('reindex'))) | ||
258 : | { | ||
259 : | |||
260 : | my @ss=$cgi->param('index_subsystem'); | ||
261 : | my $job = $fig->index_subsystems(@ss); | ||
262 : | push @$html, "<h2>ReIndexing these subsystems...</h2>\n<ul>", map {"<li>$_</li>"} @ss; | ||
263 : | push @$html, "</ul>\n<p>... is running in the background with job id $job. You may check it in the ", | ||
264 : | "<a href=\"seed_ctl.cgi?user=$user\">SEED Control Panel</a></p>\n"; | ||
265 : | &show_initial($fig,$cgi,$html); | ||
266 : | } | ||
267 : | elsif ($user && ($request eq "new_ssa") && ($cgi->param('copy_from1')) && (! $cgi->param('cols_to_take1'))) | ||
268 : | { | ||
269 : | my $user = $cgi->param('user'); | ||
270 : | my $name = $cgi->param('ssa_name'); | ||
271 : | my $copy_from1 = $cgi->param('copy_from1'); | ||
272 : | my $copy_from2 = $cgi->param('copy_from2'); | ||
273 : | my(@roles1,@roles2); | ||
274 : | |||
275 : | push(@$html,$cgi->start_form(-action => "subsys_hope.cgi", | ||
276 : | -method => 'post'), | ||
277 : | $cgi->hidden(-name => 'copy_from1', -value => $copy_from1, -override => 1), | ||
278 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
279 : | $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1), | ||
280 : | $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1) | ||
281 : | ); | ||
282 : | |||
283 : | @roles1 = $fig->subsystem_to_roles($copy_from1); | ||
284 : | if (@roles1 > 0) | ||
285 : | { | ||
286 : | push(@$html,$cgi->h1("select columns to be taken from $copy_from1"), | ||
287 : | $cgi->scrolling_list(-name => 'cols_to_take1', | ||
288 : | -values => ['all',@roles1], | ||
289 : | -size => 10, | ||
290 : | -multiple => 1 | ||
291 : | ), | ||
292 : | $cgi->hr | ||
293 : | ); | ||
294 : | } | ||
295 : | |||
296 : | if ($copy_from2) | ||
297 : | { | ||
298 : | @roles2 = $fig->subsystem_to_roles($copy_from2); | ||
299 : | if (@roles2 > 0) | ||
300 : | { | ||
301 : | push(@$html,$cgi->hidden(-name => 'copy_from2', -value => $copy_from2, -override => 1)); | ||
302 : | push(@$html,$cgi->h1("select columns to be taken from $copy_from2"), | ||
303 : | $cgi->scrolling_list(-name => 'cols_to_take2', | ||
304 : | -values => ['all',@roles2], | ||
305 : | -size => 10, | ||
306 : | -multiple => 1 | ||
307 : | ), | ||
308 : | $cgi->hr | ||
309 : | ); | ||
310 : | } | ||
311 : | } | ||
312 : | push(@$html,$cgi->submit('build new subsystem'), | ||
313 : | $cgi->end_form | ||
314 : | ); | ||
315 : | } | ||
316 : | elsif ($user && ($request eq "new_ssa") && ($cgi->param('move_from'))) | ||
317 : | { | ||
318 : | my $user = $cgi->param('user'); | ||
319 : | my $name = $cgi->param('ssa_name'); | ||
320 : | $name=$fig->clean_spaces($name); | ||
321 : | $name=~s/ /_/g; | ||
322 : | my $move_from = $cgi->param('move_from'); | ||
323 : | if (-d "$FIG_Config::data/Subsystems/$move_from" && !(-e "$FIG_Config::data/Subsystems/$name")) { | ||
324 : | my $res=`mv $FIG_Config::data/Subsystems/$move_from $FIG_Config::data/Subsystems/$name`; | ||
325 : | my $job = $fig->index_subsystems($name); | ||
326 : | push @$html, "<p>The subsystem <b>$move_from</b> was moved to <b>$name</b> and got the result $res. The new subsystem is being indexed with job id $job\n", | ||
327 : | "(check the <a href=\"seed_ctl.cgi?user=$user\">SEED control panel</a> for more information</p>\n"; | ||
328 : | } | ||
329 : | elsif (-e "$FIG_Config::data/Subsystems/$name") | ||
330 : | { | ||
331 : | push @$html, "<p>The subsystem <b>$move_from</b> was <b><i>NOT</i></b> moved because the subsystem $name already exists</p>"; | ||
332 : | } | ||
333 : | else { | ||
334 : | push @$html, "<p>The subsystem <b>$move_from</b> was not found. Sorry</p>"; | ||
335 : | } | ||
336 : | &show_initial($fig,$cgi,$html); | ||
337 : | } | ||
338 : | elsif ($request eq "new_ssa") | ||
339 : | { | ||
340 : | &new_ssa($fig,$cgi,$html); | ||
341 : | } | ||
342 : | else | ||
343 : | { | ||
344 : | &show_initial($fig,$cgi,$html); | ||
345 : | } | ||
346 : | } | ||
347 : | |||
348 : | &HTML::show_page($cgi,$html); | ||
349 : | exit; | ||
350 : | |||
351 : | |||
352 : | sub show_initial { | ||
353 : | my($fig,$cgi,$html) = @_; | ||
354 : | my($set,$when,$comment); | ||
355 : | |||
356 : | my $user = $cgi->param('user'); | ||
357 : | my @ssa = &existing_subsystem_annotations($fig); | ||
358 : | |||
359 : | if (@ssa > 0) | ||
360 : | { | ||
361 : | &format_ssa_table($cgi,$html,$user,\@ssa); | ||
362 : | } | ||
363 : | |||
364 : | my $target = "window$$"; | ||
365 : | push(@$html, $cgi->h1('To Start or Copy a Subsystem'), | ||
366 : | $cgi->start_form(-action => "subsys_hope.cgi", | ||
367 : | -target => $target, | ||
368 : | -method => 'post'), | ||
369 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
370 : | $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1), | ||
371 : | "Name of New Subsystem: ", | ||
372 : | $cgi->textfield(-name => "ssa_name", -size => 50), | ||
373 : | $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1), | ||
374 : | $cgi->br, | ||
375 : | |||
376 : | "Copy from (leave blank to start from scratch): ", | ||
377 : | $cgi->textfield(-name => "copy_from1", -size => 50), | ||
378 : | $cgi->br, | ||
379 : | |||
380 : | "Copy from (leave blank to start from scratch): ", | ||
381 : | $cgi->textfield(-name => "copy_from2", -size => 50), | ||
382 : | $cgi->br, | ||
383 : | |||
384 : | "Move from (leave blank to start from scratch): ", | ||
385 : | $cgi->textfield(-name => "move_from", -size => 50), | ||
386 : | $cgi->br, | ||
387 : | |||
388 : | $cgi->submit('start new subsystem'), | ||
389 : | $cgi->end_form, | ||
390 : | "<br>You can start a subsystem from scratch, in which case you should leave these two \"copy from\" | ||
391 : | fields blank. If you wish to just copy a subsystem (in order to become the owner so that you can modify it), | ||
392 : | just fill in one of the \"copy from\" fields with the name of the subsystem you wish to copy. If you wish to | ||
393 : | extract a a subset of the columns to build a smaller spreadsheet (which could later be merged with another one), | ||
394 : | fill in the name of the subsystem. You will be prompted for the columns that you wish to extract (choose <i>all</i> to | ||
395 : | just copy all of the columns). Finally, if you wish to build a new spreadsheet by including columns from two existing | ||
396 : | spreadsheets (including a complete merger), fill in the names of both the existing \"copy from\" subsystems" | ||
397 : | ); | ||
398 : | } | ||
399 : | |||
400 : | sub new_ssa { | ||
401 : | my($fig,$cgi,$html) = @_; | ||
402 : | |||
403 : | my $user = $cgi->param('user'); | ||
404 : | my $name = $fig->clean_spaces($cgi->param('ssa_name')); # RAE remove extraneous spaces in the name | ||
405 : | |||
406 : | if (! $user) | ||
407 : | { | ||
408 : | push(@$html,$cgi->h1('You need to specify a user before starting a new subsystem annotation')); | ||
409 : | return; | ||
410 : | } | ||
411 : | |||
412 : | if (! $name) | ||
413 : | { | ||
414 : | push(@$html,$cgi->h1("You need to specify a subsystem name, $name is not valid")); | ||
415 : | return; | ||
416 : | } | ||
417 : | |||
418 : | my $ssa = $name; | ||
419 : | $ssa =~ s/[ \/]/_/g; | ||
420 : | |||
421 : | &FIG::verify_dir("$FIG_Config::data/Subsystems"); | ||
422 : | |||
423 : | if (-d "$FIG_Config::data/Subsystems/$ssa") | ||
424 : | { | ||
425 : | push(@$html,$cgi->h1("You need to specify a new subsystem name; $ssa already is being used")); | ||
426 : | return; | ||
427 : | } | ||
428 : | |||
429 : | my $subsystem = new Subsystem($ssa,$fig,1); # create new subsystem | ||
430 : | |||
431 : | my $copy_from1 = $cgi->param('copy_from1'); | ||
432 : | $copy_from1 =~ s/[ \/]/_/g; | ||
433 : | my $copy_from2 = $cgi->param('copy_from2'); | ||
434 : | $copy_from2 =~ s/[ \/]/_/g; | ||
435 : | my @cols_to_take1 = $cgi->param('cols_to_take1'); | ||
436 : | my @cols_to_take2 = $cgi->param('cols_to_take2'); | ||
437 : | |||
438 : | |||
439 : | if ($copy_from1 && (@cols_to_take1 > 0)) | ||
440 : | { | ||
441 : | $subsystem->add_to_subsystem($copy_from1,\@cols_to_take1,"take notes"); # add columns and notes | ||
442 : | } | ||
443 : | |||
444 : | if ($copy_from2 && (@cols_to_take2 > 0)) | ||
445 : | { | ||
446 : | $subsystem->add_to_subsystem($copy_from2,\@cols_to_take2,"take notes"); # add columns and notes | ||
447 : | } | ||
448 : | |||
449 : | $subsystem->write_subsystem(); | ||
450 : | |||
451 : | $cgi->param(-name => "ssa_name", | ||
452 : | -value => $ssa); # RAE this line was needed because otherwise a newly created subsystem was not opened! | ||
453 : | $cgi->param(-name => "can_alter", | ||
454 : | -value => 1); | ||
455 : | &one_cycle($fig,$cgi,$html); | ||
456 : | } | ||
457 : | |||
458 : | # The basic update logic (cycle) includes the following steps: | ||
459 : | # | ||
460 : | # 1. Load the existing spreadsheet | ||
461 : | # 2. reconcile row and subset changes | ||
462 : | # 3. process spreadsheet changes (fill/refill/add genomes/update variants) | ||
463 : | # 4. write the updated spreadsheet back to disk | ||
464 : | # 5. render the spreadsheet | ||
465 : | # | ||
466 : | sub one_cycle { | ||
467 : | my($fig,$cgi,$html) = @_; | ||
468 : | my $subsystem; | ||
469 : | |||
470 : | my $user = $cgi->param('user'); | ||
471 : | my $ssa = $cgi->param('ssa_name'); | ||
472 : | |||
473 : | if ((! $ssa) || (! ($subsystem = new Subsystem($ssa,$fig,0)))) | ||
474 : | { | ||
475 : | push(@$html,$cgi->h1('You need to specify a subsystem')); | ||
476 : | return; | ||
477 : | } | ||
478 : | |||
479 : | if ($cgi->param('can_alter') && ($user = $cgi->param('user')) && ($user eq $subsystem->get_curator)) | ||
480 : | { | ||
481 : | handle_diagram_changes($fig, $subsystem, $cgi, $html); | ||
482 : | } | ||
483 : | |||
484 : | if (&handle_role_and_subset_changes($fig,$subsystem,$cgi,$html)) | ||
485 : | { | ||
486 : | &process_spreadsheet_changes($fig,$subsystem,$cgi,$html); | ||
487 : | |||
488 : | if ($cgi->param('can_alter') && ($user = $cgi->param('user')) && ($user eq $subsystem->get_curator)) | ||
489 : | { | ||
490 : | $subsystem->write_subsystem(); | ||
491 : | } | ||
492 : | |||
493 : | my $col; | ||
494 : | if ($cgi->param('show_sequences_in_column') && | ||
495 : | ($col = $cgi->param('col_to_align')) && | ||
496 : | ($col =~ /^\s*(\d+)\s*$/)) | ||
497 : | { | ||
498 : | &show_sequences_in_column($fig,$cgi,$html,$subsystem,$col); | ||
499 : | } | ||
500 : | else | ||
501 : | { | ||
502 : | if ($cgi->param('align_column') && | ||
503 : | ($col = $cgi->param('col_to_align')) && ($col =~ /^\s*(\d+)\s*$/)) | ||
504 : | { | ||
505 : | my $col = $1; | ||
506 : | &align_column($fig,$cgi,$html,$col,$subsystem); | ||
507 : | $cgi->delete('col_to_align'); | ||
508 : | } | ||
509 : | elsif ($cgi->param('realign_column') && | ||
510 : | ($col = $cgi->param('subcol_to_realign')) && ($col =~ /^\s*(\d+)\.(\d+)\s*$/)) | ||
511 : | { | ||
512 : | &align_subcolumn($fig,$cgi,$html,$1,$2,$subsystem); | ||
513 : | $cgi->delete('subcol_to_realign'); | ||
514 : | } | ||
515 : | &produce_html_to_display_subsystem($fig,$subsystem,$cgi,$html,$ssa); | ||
516 : | } | ||
517 : | } | ||
518 : | } | ||
519 : | |||
520 : | sub handle_role_and_subset_changes { | ||
521 : | my($fig,$subsystem,$cgi,$html) = @_; | ||
522 : | my $user; | ||
523 : | |||
524 : | if ((! $cgi->param('can_alter')) || (! ($user = $cgi->param('user'))) || ($user ne $subsystem->get_curator)) | ||
525 : | { | ||
526 : | return 1; # no changes, so... | ||
527 : | } | ||
528 : | else | ||
529 : | { | ||
530 : | my @roles = $subsystem->get_roles; | ||
531 : | my($rparm,$vparm); | ||
532 : | foreach $rparm (grep { $_ =~ /^react\d+/ } $cgi->param) | ||
533 : | { | ||
534 : | if ($vparm = $cgi->param($rparm)) | ||
535 : | { | ||
536 : | $vparm =~ s/ //g; | ||
537 : | $rparm =~ /^react(\d+)/; | ||
538 : | my $roleN = $1 - 1; | ||
539 : | $subsystem->set_reaction($roles[$roleN],$vparm); | ||
540 : | } | ||
541 : | } | ||
542 : | |||
543 : | my($role,$p,$abr,$r,$n); | ||
544 : | my @tuplesR = (); | ||
545 : | |||
546 : | ### NOTE: the meaning (order) or @roles shifts here to the NEW order | ||
547 : | @roles = grep { $_ =~ /^role/ } $cgi->param(); | ||
548 : | if (@roles == 0) { return 1 } # initial call, everything is as it was | ||
549 : | |||
550 : | foreach $role (@roles) | ||
551 : | { | ||
552 : | if (($role =~ /^role(\d+)/) && defined($n = $1)) | ||
553 : | { | ||
554 : | if ($r = $cgi->param("role$n")) | ||
555 : | { | ||
556 : | $r =~ s/^\s+//; | ||
557 : | $r =~ s/\s+$//; | ||
558 : | |||
559 : | if (($p = $cgi->param("posR$n")) && ($abr = $cgi->param("abbrev$n"))) | ||
560 : | { | ||
561 : | push(@tuplesR,[$p,$r,$abr]); | ||
562 : | } | ||
563 : | else | ||
564 : | { | ||
565 : | push(@$html,$cgi->h1("You need to give a position and abbreviation for $r")); | ||
566 : | return 0; | ||
567 : | } | ||
568 : | } | ||
569 : | } | ||
570 : | } | ||
571 : | @tuplesR = sort { $a->[0] <=> $b->[0] } @tuplesR; | ||
572 : | $subsystem->set_roles([map { [$_->[1],$_->[2]] } @tuplesR]); | ||
573 : | |||
574 : | my($subset_name,$s,$test,$entries,$entry); | ||
575 : | my @subset_names = grep { $_ =~ /^nameCS/ } $cgi->param(); | ||
576 : | |||
577 : | if (@subset_names == 0) { return 1 } | ||
578 : | |||
579 : | my %defined_subsetsC; | ||
580 : | foreach $s (@subset_names) | ||
581 : | { | ||
582 : | if (($s =~ /^nameCS(\d+)/) && defined($n = $1) && ($subset_name = $cgi->param($s))) | ||
583 : | { | ||
584 : | |||
585 : | my($text); | ||
586 : | $entries = []; | ||
587 : | if ($text = $cgi->param("subsetC$n")) | ||
588 : | { | ||
589 : | foreach $entry (split(/[\s,]+/,$text)) | ||
590 : | { | ||
591 : | if ($role = &to_role($entry,\@tuplesR)) | ||
592 : | { | ||
593 : | push(@$entries,$role); | ||
594 : | } | ||
595 : | else | ||
596 : | { | ||
597 : | push(@$html,$cgi->h1("Invalid role designation in subset $s: $entry")); | ||
598 : | return 0; | ||
599 : | } | ||
600 : | } | ||
601 : | } | ||
602 : | $defined_subsetsC{$subset_name} = $entries; | ||
603 : | } | ||
604 : | } | ||
605 : | |||
606 : | foreach $s ($subsystem->get_subset_namesC) | ||
607 : | { | ||
608 : | next if ($s eq "All"); | ||
609 : | if ($entries = $defined_subsetsC{$s}) | ||
610 : | { | ||
611 : | $subsystem->set_subsetC($s,$entries); | ||
612 : | delete $defined_subsetsC{$s}; | ||
613 : | } | ||
614 : | else | ||
615 : | { | ||
616 : | $subsystem->delete_subsetC($s); | ||
617 : | } | ||
618 : | } | ||
619 : | |||
620 : | foreach $s (keys(%defined_subsetsC)) | ||
621 : | { | ||
622 : | $subsystem->set_subsetC($s,$defined_subsetsC{$s}); | ||
623 : | } | ||
624 : | |||
625 : | my $active_subsetC; | ||
626 : | if ($active_subsetC = $cgi->param('active_subsetC')) | ||
627 : | { | ||
628 : | $subsystem->set_active_subsetC($active_subsetC); | ||
629 : | } | ||
630 : | } | ||
631 : | return 1; | ||
632 : | } | ||
633 : | |||
634 : | sub to_role { | ||
635 : | my($x,$role_tuples) = @_; | ||
636 : | my $i; | ||
637 : | |||
638 : | if (($x =~ /^(\d+)$/) && ($1 <= @$role_tuples)) { return $role_tuples->[$x-1]->[1] } | ||
639 : | |||
640 : | for ($i=0; ($i < @$role_tuples) && | ||
641 : | ($role_tuples->[0] != $x) && | ||
642 : | ($role_tuples->[1] != $x) && | ||
643 : | ($role_tuples->[2] != $x); $i++) {} | ||
644 : | if ($i < @$role_tuples) | ||
645 : | { | ||
646 : | return $role_tuples->[$i]->[1]; | ||
647 : | } | ||
648 : | return undef; | ||
649 : | } | ||
650 : | |||
651 : | sub process_spreadsheet_changes { | ||
652 : | my($fig,$subsystem,$cgi,$html) = @_; | ||
653 : | |||
654 : | my $user; | ||
655 : | if ((! $cgi->param('can_alter')) || (! ($user = $cgi->param('user'))) || ($user ne $subsystem->get_curator)) | ||
656 : | { | ||
657 : | return 1; # no changes, so... | ||
658 : | } | ||
659 : | else | ||
660 : | { | ||
661 : | my $notes = $cgi->param('notes'); | ||
662 : | if ($notes) | ||
663 : | { | ||
664 : | $subsystem->set_notes($notes); | ||
665 : | } | ||
666 : | if ($cgi->param('classif1') || $cgi->param('classif2')) | ||
667 : | { | ||
668 : | my $class; | ||
669 : | @$class=($cgi->param('classif1'), $cgi->param('classif2')); | ||
670 : | $subsystem->set_classification($class); | ||
671 : | } | ||
672 : | |||
673 : | my(@param,$param,$genome,$val); | ||
674 : | @param = grep { $_ =~ /^genome\d+\.\d+$/ } $cgi->param; | ||
675 : | |||
676 : | my %removed; | ||
677 : | foreach $param (@param) | ||
678 : | { | ||
679 : | if ($cgi->param($param) =~ /^\s*$/) | ||
680 : | { | ||
681 : | $param =~ /^genome(\d+\.\d+)/; | ||
682 : | $genome = $1; | ||
683 : | $subsystem->remove_genome($genome); | ||
684 : | $removed{$genome} = 1; | ||
685 : | } | ||
686 : | } | ||
687 : | |||
688 : | @param = grep { $_ =~ /^vcode\d+\.\d+$/ } $cgi->param; | ||
689 : | foreach $param (@param) | ||
690 : | { | ||
691 : | if ($cgi->param($param) =~ /^\s*(\S+)\s*$/) | ||
692 : | { | ||
693 : | $val = $1; | ||
694 : | $param =~ /^vcode(\d+\.\d+)/; | ||
695 : | $genome = $1; | ||
696 : | if (! $removed{$genome}) | ||
697 : | { | ||
698 : | $subsystem->set_variant_code($subsystem->get_genome_index($genome),$val); | ||
699 : | } | ||
700 : | } | ||
701 : | } | ||
702 : | |||
703 : | if ($cgi->param('refill')) | ||
704 : | { | ||
705 : | &refill_spreadsheet($fig,$subsystem); | ||
706 : | } | ||
707 : | elsif ($cgi->param('precise_fill')) | ||
708 : | { | ||
709 : | &fill_empty_cells($fig,$subsystem); | ||
710 : | } | ||
711 : | |||
712 : | my @orgs = $cgi->param('new_genome'); | ||
713 : | @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs; | ||
714 : | |||
715 : | my $org; | ||
716 : | foreach $org (@orgs) | ||
717 : | { | ||
718 : | &add_genome($fig,$subsystem,$cgi,$html,$org); | ||
719 : | } | ||
720 : | |||
721 : | my $active_subsetR; | ||
722 : | if ($active_subsetR = $cgi->param('active_subsetR')) | ||
723 : | { | ||
724 : | $subsystem->set_active_subsetR($active_subsetR); | ||
725 : | } | ||
726 : | } | ||
727 : | } | ||
728 : | |||
729 : | sub refill_spreadsheet { | ||
730 : | my($fig,$subsystem) = @_; | ||
731 : | my($genome,$role,@pegs1,@pegs2,$i); | ||
732 : | |||
733 : | foreach $genome ($subsystem->get_genomes()) | ||
734 : | { | ||
735 : | foreach $role ($subsystem->get_roles()) | ||
736 : | { | ||
737 : | @pegs1 = sort $subsystem->get_pegs_from_cell($genome,$role); | ||
738 : | @pegs2 = sort $fig->seqs_with_role($role,"master",$genome); | ||
739 : | |||
740 : | if (@pegs1 != @pegs2) | ||
741 : | { | ||
742 : | $subsystem->set_pegs_in_cell($genome,$role,\@pegs2); | ||
743 : | } | ||
744 : | else | ||
745 : | { | ||
746 : | for ($i=0; ($i < @pegs1) && ($pegs1[$i] eq $pegs2[$i]); $i++) {} | ||
747 : | if ($i < @pegs1) | ||
748 : | { | ||
749 : | $subsystem->set_pegs_in_cell($genome,$role,\@pegs2); | ||
750 : | } | ||
751 : | } | ||
752 : | } | ||
753 : | } | ||
754 : | } | ||
755 : | |||
756 : | sub fill_empty_cells { | ||
757 : | my($fig,$subsystem) = @_; | ||
758 : | my($genome,$role,@pegs); | ||
759 : | |||
760 : | foreach $genome ($subsystem->get_genomes()) | ||
761 : | { | ||
762 : | foreach $role ($subsystem->get_roles()) | ||
763 : | { | ||
764 : | @pegs = $subsystem->get_pegs_from_cell($genome,$role); | ||
765 : | if (@pegs == 0) | ||
766 : | { | ||
767 : | @pegs = $fig->seqs_with_role($role,"master",$genome); | ||
768 : | if (@pegs > 0) | ||
769 : | { | ||
770 : | $subsystem->set_pegs_in_cell($genome,$role,\@pegs); | ||
771 : | } | ||
772 : | } | ||
773 : | } | ||
774 : | } | ||
775 : | } | ||
776 : | |||
777 : | sub add_genome { | ||
778 : | my($fig,$subsystem,$cgi,$html,$genome) = @_; | ||
779 : | my($role,@pegs); | ||
780 : | |||
781 : | $subsystem->add_genome($genome); | ||
782 : | foreach $role ($subsystem->get_roles()) | ||
783 : | { | ||
784 : | @pegs = $fig->seqs_with_role($role,"master",$genome); | ||
785 : | $subsystem->set_pegs_in_cell($genome,$role,\@pegs); | ||
786 : | } | ||
787 : | } | ||
788 : | |||
789 : | sub produce_html_to_display_subsystem { | ||
790 : | my($fig,$subsystem,$cgi,$html,$ssa) = @_; | ||
791 : | |||
792 : | my $user = $cgi->param('user'); | ||
793 : | my $ssa = $cgi->param('ssa_name'); | ||
794 : | my $can_alter = ($cgi->param('can_alter') && $user && ($user eq $subsystem->get_curator)); | ||
795 : | my $tagvalcolor; # RAE: this is a reference to a hash that stores the colors of cells by tag. This has to be consistent over the whole table. | ||
796 : | |||
797 : | my $name = $ssa; | ||
798 : | $name =~ s/_/ /g; | ||
799 : | $ssa =~ s/[ \/]/_/g; | ||
800 : | my $curator = $fig->subsystem_curator($ssa); | ||
801 : | push(@$html, $cgi->h1("Subsystem: $name"), | ||
802 : | $cgi->h1("Author: $curator"), | ||
803 : | $cgi->start_form(-action => "subsys_hope.cgi", | ||
804 : | -method => 'post', | ||
805 : | -enctype => &CGI::MULTIPART), | ||
806 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
807 : | $cgi->hidden(-name => 'request', -value => 'show_ssa', -override => 1), | ||
808 : | $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1), | ||
809 : | $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1), | ||
810 : | $cgi->br, | ||
811 : | ); | ||
812 : | |||
813 : | # RAE: First, a sanity check. | ||
814 : | # We may have to move this a little earlier, and show probably throw some nicer | ||
815 : | # errors to the end user (.e.g try setting can_alter and choosing an illegitimate ss | ||
816 : | # Do we know about this subsystem: | ||
817 : | my $ssaQ = quotemeta $ssa; | ||
818 : | unless (grep {/$ssaQ/} map {$_->[0]} &existing_subsystem_annotations($fig)) | ||
819 : | { | ||
820 : | # No, we don't know about this subsystem | ||
821 : | my $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user"; | ||
822 : | push @$html, "Sorry. $name is not a valid subsystem. <p>\n", | ||
823 : | "Please return to the <a href=\"$url\">Subsystems Page</a> and choose an exisiting subsystem. <p>\n", | ||
824 : | "Sorry."; | ||
825 : | return undef; | ||
826 : | } | ||
827 : | |||
828 : | |||
829 : | &format_roles($fig,$cgi,$html,$subsystem,$can_alter); | ||
830 : | &format_subsets($fig,$cgi,$html,$subsystem,$can_alter); | ||
831 : | |||
832 : | &format_diagrams($fig, $cgi, $html, $subsystem, $can_alter); | ||
833 : | |||
834 : | # | ||
835 : | # Put link into constructs tool. | ||
836 : | # | ||
837 : | |||
838 : | if ($can_alter) | ||
839 : | { | ||
840 : | push(@$html, $cgi->p, | ||
841 : | $cgi->a({href => "construct.cgi?ssa=$ssa&user=$user", | ||
842 : | target => "_blank"}, | ||
843 : | "Define higher level constructs."), | ||
844 : | $cgi->p); | ||
845 : | } | ||
846 : | |||
847 : | |||
848 : | # Display the subsystem table rows, saving the list genomes displayed | ||
849 : | |||
850 : | my $active_genome_list = &format_rows($fig,$cgi,$html,$subsystem, $tagvalcolor); | ||
851 : | |||
852 : | |||
853 : | if ( $can_alter ) { format_extend_with($fig,$cgi,$html,$subsystem) } | ||
854 : | |||
855 : | my $esc_ssa = uri_escape( $ssa ); | ||
856 : | push @$html, "<TABLE width=\"100%\">\n", | ||
857 : | " <TR>\n", | ||
858 : | ($can_alter) ? " <TD>" . $cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill') . "</TD>\n" : (), | ||
859 : | " <TD><a href=\"/FIG/Html/conflict_resolution.html\" class=\"help\" target=\"help\">Help on conflict resolution</a></TD>\n", | ||
860 : | " <TD><a href=\"/FIG/Html/seedtips.html#edit_variants\" class=\"help\" target=\"help\">Help on editing variants</a></TD>\n", | ||
861 : | " <TD><a href=\"ss_export.cgi?user=$user&ssa_name=$esc_ssa\" class=\"help\">Export subsystem data</a></TD>\n", | ||
862 : | " </TR>\n", | ||
863 : | "</TABLE>\n"; | ||
864 : | |||
865 : | if ($can_alter) | ||
866 : | { | ||
867 : | push(@$html,$cgi->submit('update spreadsheet'),$cgi->br); | ||
868 : | } | ||
869 : | else | ||
870 : | { | ||
871 : | push(@$html,$cgi->br); | ||
872 : | push(@$html,$cgi->submit('show spreadsheet'),$cgi->br); | ||
873 : | } | ||
874 : | push(@$html,$cgi->checkbox(-name => 'show_KGML', -value =>1, -checked=>0, -label => 'show KEGG data'),$cgi->br); | ||
875 : | push(@$html,$cgi->checkbox(-name => 'ignore_alt', -value => 1, -override => 1, -label => 'ignore alternatives', -checked => ($cgi->param('ignore_alt'))),$cgi->br); | ||
876 : | push(@$html,$cgi->checkbox(-name => 'ext_ids', -value => 1, -checked => 0, -label => 'use external ids'),$cgi->br); | ||
877 : | push(@$html,$cgi->checkbox(-name => 'show_clusters', -value => 1, -checked => 0,-label => 'show clusters'),$cgi->br); | ||
878 : | my $opt=$fig->get_tags("genome"); # all the tags we know about | ||
879 : | my @options=sort {uc($a) cmp uc($b)} keys %$opt; | ||
880 : | unshift(@options, undef); # a blank field at the start | ||
881 : | push(@$html,"color rows by each organism's attribute: ", $cgi->popup_menu(-name => 'color_by_ga', -values=>\@options), $cgi->br); | ||
882 : | |||
883 : | $opt=$fig->get_tags("peg"); # all the peg tags | ||
884 : | @options=sort {$a cmp $b} keys %$opt; | ||
885 : | unshift(@options, undef); | ||
886 : | push(@$html,"color columns by each PEGs attribute: ", $cgi->popup_menu(-name => 'color_by_peg_tag', -values=>\@options), $cgi->br); | ||
887 : | |||
888 : | push @$html, $cgi->checkbox(-name => 'show_missing', -value => 1, -checked => 0, -override => 1,-label => 'show missing'), | ||
889 : | $cgi->br, $cgi->br; | ||
890 : | |||
891 : | |||
892 : | # Format the organism list for a pop-up menu: | ||
893 : | |||
894 : | my @genomes = sort { lc $a->[1] cmp lc $b->[1] } map { [ $_->[0], "$_->[1] [$_->[0]]" ] } @$active_genome_list; | ||
895 : | unshift @genomes, [ '', 'select it in this menu' ]; | ||
896 : | |||
897 : | # Make a list of index number and roles for pop-up selections: | ||
898 : | |||
899 : | my @roles = map { [ $subsystem->get_role_index( $_ ) + 1, $_ ] } $subsystem->get_roles; | ||
900 : | unshift @roles, [ '', 'select it in this menu' ]; | ||
901 : | |||
902 : | push @$html, "<table><tr><td>", | ||
903 : | $cgi->checkbox(-name => 'show_missing_including_matches', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches'), $cgi->br, | ||
904 : | $cgi->checkbox(-name => 'show_missing_including_matches_in_ss', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches in ss'), " ", | ||
905 : | "</td>\n<td><big><big><big>} {</big></big></big></td>", | ||
906 : | "<td>", | ||
907 : | "[To restrict to a single genome: ", | ||
908 : | $cgi->popup_menu( -name => 'just_genome', | ||
909 : | -values => [ map { $_->[0] } @genomes ], | ||
910 : | -labels => { map { ( $_->[0], $_->[1] ) } @genomes } | ||
911 : | ), "]", $cgi->br, | ||
912 : | "[To restrict to a single role: ", | ||
913 : | $cgi->popup_menu( -name => 'just_role', | ||
914 : | -values => [ map { $_->[0] } @roles ], | ||
915 : | -labels => { map { ( $_->[0], $_->[1] ) } @roles } | ||
916 : | ), | ||
917 : | "]</td></tr></table>\n", | ||
918 : | $cgi->br; | ||
919 : | |||
920 : | |||
921 : | push @$html, "<table><tr><td>", | ||
922 : | $cgi->checkbox(-name => 'check_assignments', -value => 1, -checked => 0, -override => 1, -label => 'check assignments'), | ||
923 : | " [", $cgi->checkbox(-name => 'strict_check', -value => 1, -checked => 0, -override => 1, -label => 'strict'), "] ", | ||
924 : | "</td>\n<td><big><big><big>{</big></big></big></td>", | ||
925 : | "<td>", | ||
926 : | "[To restrict to a single genome: ", | ||
927 : | $cgi->popup_menu( -name => 'just_genome_assignments', | ||
928 : | -values => [ map { $_->[0] } @genomes ], | ||
929 : | -labels => { map { ( $_->[0], $_->[1] ) } @genomes } | ||
930 : | ), "]", $cgi->br, | ||
931 : | "[To restrict to a single role: ", | ||
932 : | $cgi->popup_menu( -name => 'just_role_assignments', | ||
933 : | -values => [ map { $_->[0] } @roles ], | ||
934 : | -labels => { map { ( $_->[0], $_->[1] ) } @roles } | ||
935 : | ), | ||
936 : | "]</td></tr></table>\n", | ||
937 : | $cgi->br; | ||
938 : | |||
939 : | |||
940 : | if ($can_alter) | ||
941 : | { | ||
942 : | push(@$html,$cgi->checkbox(-name => 'refill', -value => 1, -checked => 0, -override => 1,-label => 'refill spreadsheet from scratch'),$cgi->br); | ||
943 : | } | ||
944 : | |||
945 : | push(@$html,$cgi->checkbox(-name => 'show_dups', -value => 1, -checked => 0, -override => 1,-label => 'show duplicates'),$cgi->br); | ||
946 : | push(@$html,$cgi->checkbox(-name => 'check_problems', -value => 1, -checked => 0, -override => 1,-label => 'show PEGs in roles that do not match precisely'),$cgi->br); | ||
947 : | if ($can_alter) | ||
948 : | { | ||
949 : | push(@$html,$cgi->checkbox(-name => 'add_solid', -value => 1, -checked => 0, -override => 1,-label => 'add genomes with solid hits'),$cgi->br); | ||
950 : | } | ||
951 : | |||
952 : | push(@$html,$cgi->checkbox(-name => 'show_coupled_fast', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs fast [depends on existing pins/clusters]'),$cgi->br); | ||
953 : | |||
954 : | push(@$html,$cgi->checkbox(-name => 'show_coupled', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs [figure 2 minutes per PEG in spreadsheet]'),$cgi->br); | ||
955 : | |||
956 : | # RAE Hide -1 variants | ||
957 : | push(@$html,$cgi->checkbox(-name => 'show_minus1', -value=> 1, -checked => 0, -label => 'show -1 variants'),$cgi->br); | ||
958 : | |||
959 : | # Alignment functions: | ||
960 : | |||
961 : | push @$html, $cgi->hr, | ||
962 : | # $cgi->br, "Column (specify the number of the column): ", | ||
963 : | # $cgi->textfield(-name => "col_to_align", -size => 7), | ||
964 : | "For sequences in a column (i.e., role): ", | ||
965 : | $cgi->popup_menu( -name => 'col_to_align', | ||
966 : | -values => [ map { $_->[0] } @roles ], | ||
967 : | -labels => { map { ( $_->[0], $_->[1] ) } @roles } | ||
968 : | ), | ||
969 : | $cgi->br, | ||
970 : | $cgi->submit(-value => "Show Sequences in Column", | ||
971 : | -name => "show_sequences_in_column"), | ||
972 : | $cgi->br, | ||
973 : | $cgi->submit(-value => "Align Sequences in Column", | ||
974 : | -name => "align_column"), | ||
975 : | $cgi->br, | ||
976 : | $cgi->br, "Realign subgroup within a column (adding homologs): ", | ||
977 : | $cgi->textfield(-name => "subcol_to_realign", -size => 7), | ||
978 : | $cgi->br, "Include homologs that pass the following threshhold: ", | ||
979 : | $cgi->textfield(-name => "include_homo", -size => 10)," (leave blank to see just column)", | ||
980 : | " Max homologous seqs: ",$cgi->textfield(-name => "max_homo", -value => 100, -size => 6), | ||
981 : | $cgi->br, | ||
982 : | $cgi->submit(-value => "Realign Sequences in Column", | ||
983 : | -name => "realign_column"), | ||
984 : | $cgi->hr; | ||
985 : | |||
986 : | # RAE: A new function to reannotate a single column | ||
987 : | # I don't understand how you get CGI.pm to reset (and never have). | ||
988 : | # $cgi->delete("col_to_annotate"); # this does nothing to my script and there is always the last number in this box | ||
989 : | #push(@$html, $cgi->br,"Change annotation for column: ", $cgi->textfield(-name => "col_to_annotate", -size => 7)); | ||
990 : | push(@$html, $cgi->br,"Change annotation for column: ", '<input type="text" name="col_to_annotate" value="" size="7">'); | ||
991 : | |||
992 : | if ($can_alter) | ||
993 : | { | ||
994 : | push(@$html, | ||
995 : | $cgi->p. $cgi->hr."If you wish to check the subsystem, ", | ||
996 : | $cgi->a({href => "check_subsys.cgi?user=$user&subsystem=$ssa&request=check_ssa"}, | ||
997 : | "click here"), | ||
998 : | # $cgi->br, | ||
999 : | # $cgi->p. $cgi->hr."If you wish to reset variants for the subsystem, ", | ||
1000 : | # $cgi->a({href => "set_variants.cgi?user=$user&subsystem=$ssa&request=show_variants",target => "set_variants"}, | ||
1001 : | # "click here"), | ||
1002 : | $cgi->br, | ||
1003 : | $cgi->p, | ||
1004 : | $cgi->hr, | ||
1005 : | "You should resynch PEG connections only if you detect PEGs that should be connected to the | ||
1006 : | spreadsheet, but do not seem to be. This can only reflect an error in the code. If you find | ||
1007 : | yourself having to use it, send mail to Ross.", | ||
1008 : | $cgi->br, | ||
1009 : | $cgi->submit(-value => "Resynch PEG Connections", | ||
1010 : | -name => "resynch_peg_connections"), | ||
1011 : | $cgi->br, | ||
1012 : | $cgi->submit(-value => "Start automated subsystem extension", | ||
1013 : | -name => "extend_with_billogix"), | ||
1014 : | $cgi->br); | ||
1015 : | } | ||
1016 : | |||
1017 : | my $notes = $subsystem->get_notes(); | ||
1018 : | if ($can_alter) | ||
1019 : | { | ||
1020 : | push(@$html,$cgi->hr,"NOTES:\n",$cgi->br,$cgi->textarea(-name => 'notes', -rows => 40, -cols => 100, -value => $notes)); | ||
1021 : | } | ||
1022 : | elsif ($notes) | ||
1023 : | { | ||
1024 : | push(@$html,$cgi->h2('notes'),"<pre width=80>$notes</pre>"); | ||
1025 : | } | ||
1026 : | |||
1027 : | # RAE Modified to add a line with the classification | ||
1028 : | my $class=$subsystem->get_classification(); | ||
1029 : | if ($can_alter) | ||
1030 : | { | ||
1031 : | push(@$html, $cgi->hr, "CLASSIFICATION:\n", $cgi->textfield(-name=>"classif1", -value=>$$class[0], -size=>40), | ||
1032 : | $cgi->textfield(-name=>"classif2", -value=>$$class[1], -size=>40)); | ||
1033 : | } | ||
1034 : | elsif ($class) | ||
1035 : | { | ||
1036 : | push (@$html, $cgi->h2('Classification'), "<table><tr><td>$$class[0]</td><td>$$class[1]</td></tr></table>\n"); | ||
1037 : | } | ||
1038 : | |||
1039 : | push(@$html, $cgi->end_form); | ||
1040 : | |||
1041 : | my $target = "align$$"; | ||
1042 : | my @roles = $subsystem->get_roles; | ||
1043 : | my $i; | ||
1044 : | my $dir = $subsystem->get_dir; | ||
1045 : | my $rolesA = &existing_trees($dir,\@roles); | ||
1046 : | |||
1047 : | if (@$rolesA > 0) | ||
1048 : | { | ||
1049 : | push(@$html, $cgi->hr, | ||
1050 : | $cgi->h1('To Assign Using a Tree'), | ||
1051 : | $cgi->start_form(-action => "assign_using_tree.cgi", | ||
1052 : | -target => $target, | ||
1053 : | -method => 'post'), | ||
1054 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
1055 : | $cgi->hidden(-name => 'ali_dir', -value => "$dir/Alignments", -override => 1), | ||
1056 : | $cgi->scrolling_list(-name => 'ali_num', | ||
1057 : | -values => $rolesA, | ||
1058 : | -size => 10, | ||
1059 : | -multiple => 0 | ||
1060 : | ), | ||
1061 : | $cgi->br, | ||
1062 : | $cgi->submit(-value => "use_tree", | ||
1063 : | -name => "use_tree"), | ||
1064 : | $cgi->end_form | ||
1065 : | ); | ||
1066 : | } | ||
1067 : | |||
1068 : | push(@$html, $cgi->hr); | ||
1069 : | |||
1070 : | #start editing | ||
1071 : | if ($cgi->param('show_KGML')) | ||
1072 : | { | ||
1073 : | my $kgml = new KGMLData; | ||
1074 : | $kgml->show_matching_pathways($subsystem,$cgi,$html); | ||
1075 : | } | ||
1076 : | #end editing | ||
1077 : | if ($cgi->param('show_missing')) | ||
1078 : | { | ||
1079 : | &format_missing($fig,$cgi,$html,$subsystem); | ||
1080 : | } | ||
1081 : | |||
1082 : | if ($cgi->param('show_missing_including_matches')) | ||
1083 : | { | ||
1084 : | &format_missing_including_matches($fig,$cgi,$html,$subsystem); | ||
1085 : | } | ||
1086 : | if ($cgi->param('show_missing_including_matches_in_ss')) | ||
1087 : | { | ||
1088 : | &format_missing_including_matches_in_ss($fig,$cgi,$html,$subsystem); | ||
1089 : | } | ||
1090 : | |||
1091 : | |||
1092 : | if ($cgi->param('check_assignments')) | ||
1093 : | { | ||
1094 : | &format_check_assignments($fig,$cgi,$html,$subsystem); | ||
1095 : | } | ||
1096 : | |||
1097 : | if ($cgi->param('show_dups')) | ||
1098 : | { | ||
1099 : | &format_dups($fig,$cgi,$html,$subsystem); | ||
1100 : | } | ||
1101 : | |||
1102 : | if ($cgi->param('show_coupled')) | ||
1103 : | { | ||
1104 : | &format_coupled($fig,$cgi,$html,$subsystem,"careful"); | ||
1105 : | } | ||
1106 : | elsif ($cgi->param('show_coupled_fast')) | ||
1107 : | { | ||
1108 : | &format_coupled($fig,$cgi,$html,$subsystem,"fast"); | ||
1109 : | } | ||
1110 : | |||
1111 : | my $col; | ||
1112 : | if ($col = $cgi->param('col_to_annotate')) | ||
1113 : | { | ||
1114 : | &annotate_column($fig,$cgi,$html,$col,$subsystem); | ||
1115 : | } | ||
1116 : | } | ||
1117 : | |||
1118 : | |||
1119 : | #----------------------------------------------------------------------------- | ||
1120 : | # Selection list of complete genomes not in spreadsheet: | ||
1121 : | #----------------------------------------------------------------------------- | ||
1122 : | |||
1123 : | sub format_extend_with { | ||
1124 : | my( $fig, $cgi, $html, $subsystem ) = @_; | ||
1125 : | |||
1126 : | my %genomes = map { $_ => 1 } $subsystem->get_genomes(); | ||
1127 : | |||
1128 : | # | ||
1129 : | # Use $fig->genomes( complete, restricted, domain ) to get org list: | ||
1130 : | # | ||
1131 : | my $req_comp = $cgi->param( 'complete' ) || 'Only "complete"'; | ||
1132 : | my $complete = ( $req_comp =~ /^all$/i ) ? undef : "complete"; | ||
1133 : | my @orgs = map { [ $_ , &ext_genus_species( $fig, $_ ) ] } | ||
1134 : | grep { ! $genomes{ $_ } } | ||
1135 : | $fig->genomes( $complete, undef ); | ||
1136 : | |||
1137 : | # | ||
1138 : | # Put it in the order requested by the user: | ||
1139 : | # | ||
1140 : | my $pick_order = $cgi->param('pick_order') || 'Alphabetic'; | ||
1141 : | if ( $pick_order eq "Phylogenetic" ) | ||
1142 : | { | ||
1143 : | @orgs = sort { $a->[2] cmp $b->[2] } | ||
1144 : | map { push @$_, $fig->taxonomy_of( $_->[0] ); $_ } | ||
1145 : | @orgs; | ||
1146 : | } | ||
1147 : | elsif ( $pick_order eq "Genome ID" ) | ||
1148 : | { | ||
1149 : | @orgs = sort { $a->[2]->[0] <=> $b->[2]->[0] || $a->[2]->[1] <=> $b->[2]->[1] } | ||
1150 : | map { push @$_, [ split /\./ ]; $_ } | ||
1151 : | @orgs; | ||
1152 : | } | ||
1153 : | else | ||
1154 : | { | ||
1155 : | $pick_order = 'Alphabetic'; | ||
1156 : | @orgs = sort { $a->[1] cmp $b->[1] } @orgs; | ||
1157 : | } | ||
1158 : | |||
1159 : | @orgs = map { "$_->[1] ($_->[0])" } @orgs; | ||
1160 : | |||
1161 : | # | ||
1162 : | # Radio buttons to let the user choose the order they want for the list: | ||
1163 : | # | ||
1164 : | my @order_opt = $cgi->radio_group( -name => 'pick_order', | ||
1165 : | -values => [ 'Alphabetic', 'Phylogenetic', 'Genome ID' ], | ||
1166 : | -default => $pick_order, | ||
1167 : | -override => 1 | ||
1168 : | ); | ||
1169 : | |||
1170 : | # | ||
1171 : | # Radio buttons to let the user choose to include incomplete genomes: | ||
1172 : | # | ||
1173 : | my @complete = $cgi->radio_group( -name => 'complete', | ||
1174 : | -default => $req_comp, | ||
1175 : | -override => 1, | ||
1176 : | -values => [ 'All', 'Only "complete"' ] | ||
1177 : | ); | ||
1178 : | |||
1179 : | # | ||
1180 : | # Display the pick list, and options: | ||
1181 : | # | ||
1182 : | push( @$html, $cgi->h1('Pick Organisms to Extend with'), "\n", | ||
1183 : | "<TABLE>\n", | ||
1184 : | " <TR>\n", | ||
1185 : | " <TD>", | ||
1186 : | $cgi->scrolling_list( -name => 'new_genome', | ||
1187 : | -values => [ @orgs ], | ||
1188 : | -size => 10, | ||
1189 : | -multiple => 1 | ||
1190 : | ), | ||
1191 : | " </TD>\n", | ||
1192 : | " <TD>", | ||
1193 : | join( "<BR>\n", "<b>Order of selection list:</b>", @order_opt, | ||
1194 : | "<b>Completeness?</b>", @complete | ||
1195 : | ), "\n", | ||
1196 : | " </TD>\n", | ||
1197 : | " </TR>\n", | ||
1198 : | "</TABLE>\n", | ||
1199 : | $cgi->hr | ||
1200 : | ); | ||
1201 : | } | ||
1202 : | |||
1203 : | |||
1204 : | sub format_roles { | ||
1205 : | my($fig,$cgi,$html,$subsystem,$can_alter) = @_; | ||
1206 : | my($i); | ||
1207 : | |||
1208 : | my @roles = $subsystem->get_roles; | ||
1209 : | my $sub_dir = $subsystem->get_dir; | ||
1210 : | |||
1211 : | my $reactions = $subsystem->get_reactions; | ||
1212 : | |||
1213 : | my $n = 1; | ||
1214 : | my $col_hdrs = ["Column","Abbrev","Functional Role"]; | ||
1215 : | |||
1216 : | if ($can_alter) | ||
1217 : | { | ||
1218 : | push(@$col_hdrs,"KEGG Reactions"); | ||
1219 : | push(@$col_hdrs,"Edit Reactions"); | ||
1220 : | } | ||
1221 : | elsif ($reactions) | ||
1222 : | { | ||
1223 : | push(@$col_hdrs,"KEGG Reactions"); | ||
1224 : | } | ||
1225 : | |||
1226 : | my $tab = []; | ||
1227 : | |||
1228 : | &format_existing_roles($fig,$cgi,$html,$subsystem,$tab,\$n,$can_alter,$reactions,\@roles); | ||
1229 : | if ($cgi->param('can_alter')) | ||
1230 : | { | ||
1231 : | for ($i=0; ($i < 5); $i++) | ||
1232 : | { | ||
1233 : | &format_role($fig,$cgi,$html,$subsystem,$tab,$n,"",$can_alter,undef); | ||
1234 : | $n++; | ||
1235 : | } | ||
1236 : | } | ||
1237 : | push(@$html,&HTML::make_table($col_hdrs,$tab,"Functional Roles"), | ||
1238 : | $cgi->hr | ||
1239 : | ); | ||
1240 : | } | ||
1241 : | |||
1242 : | sub format_existing_roles { | ||
1243 : | my($fig,$cgi,$html,$subsystem,$tab,$nP,$can_alter,$reactions,$roles) = @_; | ||
1244 : | my($role); | ||
1245 : | |||
1246 : | foreach $role (@$roles) | ||
1247 : | { | ||
1248 : | &format_role($fig,$cgi,$html,$subsystem,$tab,$$nP,$role,$can_alter,$reactions); | ||
1249 : | $$nP++; | ||
1250 : | } | ||
1251 : | } | ||
1252 : | |||
1253 : | sub format_role { | ||
1254 : | my($fig,$cgi,$html,$subsystem,$tab,$n,$role,$can_alter,$reactions) = @_; | ||
1255 : | my($abbrev,$reactT); | ||
1256 : | |||
1257 : | my $react = $reactions ? join(",", map { &HTML::reaction_link($_) } @{$reactions->{$role}}) : ""; | ||
1258 : | |||
1259 : | $abbrev = $role ? $subsystem->get_role_abbr($subsystem->get_role_index($role)) : ""; | ||
1260 : | |||
1261 : | my($posT,$abbrevT,$roleT); | ||
1262 : | if ($can_alter) | ||
1263 : | { | ||
1264 : | $posT = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1); | ||
1265 : | $abbrevT = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1); | ||
1266 : | $roleT = $cgi->textfield(-name => "role$n", -size => 80, -value => $role, -override => 1); | ||
1267 : | $reactT = $cgi->textfield(-name => "react$n", -size => 20, -value => "", -override => 1); | ||
1268 : | } | ||
1269 : | else | ||
1270 : | { | ||
1271 : | push(@$html,$cgi->hidden(-name => "posR$n", -value => $n, -override => 1), | ||
1272 : | $cgi->hidden(-name => "abbrev$n", -value => $abbrev, -override => 1), | ||
1273 : | $cgi->hidden(-name => "role$n", -value => $role, -override => 1)); | ||
1274 : | $posT = $n; | ||
1275 : | $abbrevT = $abbrev; | ||
1276 : | $roleT = $role; | ||
1277 : | } | ||
1278 : | # | ||
1279 : | # Wrap the first element in the table with a <A NAME="role_rolename"> tag | ||
1280 : | # so we can zing to it from elsewhere. We remove any non-alphanumeric | ||
1281 : | # chars in the role name. | ||
1282 : | # | ||
1283 : | |||
1284 : | my $posT_html; | ||
1285 : | { | ||
1286 : | my $rn = $role; | ||
1287 : | $rn =~ s/[ \/]/_/g; | ||
1288 : | $rn =~ s/\W//g; | ||
1289 : | |||
1290 : | $posT_html = "<a name=\"$rn\">$posT</a>"; | ||
1291 : | } | ||
1292 : | |||
1293 : | my $row = [$posT_html,$abbrevT,$roleT]; | ||
1294 : | if ($can_alter) | ||
1295 : | { | ||
1296 : | push(@$row,$react); | ||
1297 : | push(@$row,$reactT); | ||
1298 : | } | ||
1299 : | elsif ($reactions) | ||
1300 : | { | ||
1301 : | push(@$row,$react); | ||
1302 : | } | ||
1303 : | push(@$tab,$row); | ||
1304 : | |||
1305 : | if ($cgi->param('check_problems')) | ||
1306 : | { | ||
1307 : | my @roles = grep { $_->[0] ne $role } &gene_functions_in_col($fig,$role,$subsystem); | ||
1308 : | my($x,$peg); | ||
1309 : | foreach $x (@roles) | ||
1310 : | { | ||
1311 : | push(@$tab,["","",$x->[0]]); | ||
1312 : | push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]); | ||
1313 : | } | ||
1314 : | } | ||
1315 : | } | ||
1316 : | |||
1317 : | sub gene_functions_in_col { | ||
1318 : | my($fig,$role,$subsystem) = @_; | ||
1319 : | my(%roles,$peg,$func); | ||
1320 : | |||
1321 : | |||
1322 : | # RAE this is dying if $subsystem->get_col($subsystem->get_role_index($role) + 1) is not defined | ||
1323 : | # it is also not returning the right answer, so we need to fix it. | ||
1324 : | # I am not sure why this is incremented by one here (see the note) because it is not right | ||
1325 : | # and if you don't increment it by one it is right. | ||
1326 : | |||
1327 : | # incr by 1 to get col indexed from 1 (not 0) | ||
1328 : | #my @pegs = map { @$_ } @{$subsystem->get_col($subsystem->get_role_index($role) + 1)}; | ||
1329 : | |||
1330 : | return undef unless ($role); # this takes care of one error | ||
1331 : | my $col_role=$subsystem->get_col($subsystem->get_role_index($role)); | ||
1332 : | return undef unless (defined $col_role); | ||
1333 : | my @pegs = map { @$_ } @$col_role; | ||
1334 : | |||
1335 : | foreach $peg (@pegs) | ||
1336 : | { | ||
1337 : | if ($func = $fig->function_of($peg)) | ||
1338 : | { | ||
1339 : | push(@{$roles{$func}},$peg); | ||
1340 : | } | ||
1341 : | } | ||
1342 : | return map { [$_,$roles{$_}] } sort keys(%roles); | ||
1343 : | } | ||
1344 : | |||
1345 : | sub format_subsets { | ||
1346 : | my($fig,$cgi,$html,$subsystem,$can_alter) = @_; | ||
1347 : | |||
1348 : | &format_subsetsC($fig,$cgi,$html,$subsystem,$can_alter); | ||
1349 : | &format_subsetsR($fig,$cgi,$html,$subsystem); | ||
1350 : | } | ||
1351 : | |||
1352 : | sub format_subsetsC { | ||
1353 : | my($fig,$cgi,$html,$subsystem,$can_alter) = @_; | ||
1354 : | |||
1355 : | my $col_hdrs = ["Subset","Includes These Roles"]; | ||
1356 : | my $tab = []; | ||
1357 : | |||
1358 : | my $n = 1; | ||
1359 : | &format_existing_subsetsC($cgi,$html,$subsystem,$tab,\$n,$can_alter); | ||
1360 : | |||
1361 : | if ($can_alter) | ||
1362 : | { | ||
1363 : | my $i; | ||
1364 : | for ($i=0; ($i < 5); $i++) | ||
1365 : | { | ||
1366 : | &format_subsetC($cgi,$html,$subsystem,$tab,$n,""); | ||
1367 : | $n++; | ||
1368 : | } | ||
1369 : | } | ||
1370 : | |||
1371 : | push(@$html,&HTML::make_table($col_hdrs,$tab,"Subsets of Roles"), | ||
1372 : | $cgi->hr | ||
1373 : | ); | ||
1374 : | |||
1375 : | my @subset_names = $subsystem->get_subset_namesC; | ||
1376 : | if (@subset_names > 1) | ||
1377 : | { | ||
1378 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
1379 : | push(@$html,$cgi->scrolling_list(-name => 'active_subsetC', | ||
1380 : | -values => [@subset_names], | ||
1381 : | -default => $active_subsetC | ||
1382 : | ), | ||
1383 : | $cgi->br | ||
1384 : | ); | ||
1385 : | } | ||
1386 : | else | ||
1387 : | { | ||
1388 : | push(@$html,$cgi->hidden(-name => 'active_subsetC', -value => 'All', -override => 1)); | ||
1389 : | } | ||
1390 : | } | ||
1391 : | |||
1392 : | sub format_subsetsR { | ||
1393 : | my($fig,$cgi,$html,$subsystem) = @_; | ||
1394 : | my($i); | ||
1395 : | |||
1396 : | my $link = &tree_link; | ||
1397 : | push(@$html,$cgi->br,$link,$cgi->br); | ||
1398 : | |||
1399 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
1400 : | |||
1401 : | my @tmp = grep { $_ ne "All" } sort $subsystem->get_subset_namesR; | ||
1402 : | push(@$html,$cgi->scrolling_list(-name => 'active_subsetR', | ||
1403 : | -values => ["All",@tmp], | ||
1404 : | -default => $active_subsetR, | ||
1405 : | -size => 5 | ||
1406 : | ), | ||
1407 : | $cgi->br | ||
1408 : | ); | ||
1409 : | } | ||
1410 : | |||
1411 : | sub format_existing_subsetsC { | ||
1412 : | my($cgi,$html,$subsystem,$tab,$nP,$can_alter) = @_; | ||
1413 : | my($nameCS); | ||
1414 : | |||
1415 : | foreach $nameCS (sort $subsystem->get_subset_namesC) | ||
1416 : | { | ||
1417 : | if ($nameCS !~ /all/i) | ||
1418 : | { | ||
1419 : | &format_subsetC($cgi,$html,$subsystem,$tab,$$nP,$nameCS); | ||
1420 : | $$nP++; | ||
1421 : | } | ||
1422 : | } | ||
1423 : | } | ||
1424 : | |||
1425 : | sub format_subsetC { | ||
1426 : | my($cgi,$html,$subsystem,$tab,$n,$nameCS) = @_; | ||
1427 : | |||
1428 : | if ($nameCS ne "All") | ||
1429 : | { | ||
1430 : | my $subset = $nameCS ? join(",",map { $subsystem->get_role_index($_) + 1 } $subsystem->get_subsetC_roles($nameCS)) : ""; | ||
1431 : | |||
1432 : | $nameCS = $subset ? $nameCS : ""; | ||
1433 : | |||
1434 : | my($posT,$subsetT); | ||
1435 : | |||
1436 : | $posT = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1); | ||
1437 : | $subsetT = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1); | ||
1438 : | push(@$tab,[$posT,$subsetT]); | ||
1439 : | } | ||
1440 : | } | ||
1441 : | |||
1442 : | |||
1443 : | # | ||
1444 : | # Handle changes to diagrams. | ||
1445 : | # | ||
1446 : | |||
1447 : | sub handle_diagram_changes | ||
1448 : | { | ||
1449 : | my($fig, $subsystem, $cgi, $html) = @_; | ||
1450 : | my $changed; | ||
1451 : | |||
1452 : | return unless $cgi->param("diagram_action"); | ||
1453 : | |||
1454 : | my @actions = grep { /^diagram_/ } $cgi->param(); | ||
1455 : | |||
1456 : | for my $action (@actions) | ||
1457 : | { | ||
1458 : | my $value = $cgi->param($action); | ||
1459 : | warn "Diagram action $action: $value\n"; | ||
1460 : | if ($action =~ /^diagram_delete_(\S+)/ and $value eq "on") | ||
1461 : | { | ||
1462 : | $subsystem->delete_diagram($1); | ||
1463 : | $changed++; | ||
1464 : | } | ||
1465 : | elsif ($action =~ /^diagram_rename_(\S+)/ and $value ne "") | ||
1466 : | { | ||
1467 : | $subsystem->rename_diagram($1, $value); | ||
1468 : | $changed++; | ||
1469 : | } | ||
1470 : | } | ||
1471 : | |||
1472 : | my $fh = $cgi->upload("diagram_image_file"); | ||
1473 : | |||
1474 : | if ($fh) | ||
1475 : | { | ||
1476 : | $subsystem->create_new_diagram($fh, $cgi->param("diagram_new_name")); | ||
1477 : | $changed++; | ||
1478 : | } | ||
1479 : | |||
1480 : | $subsystem->incr_version() if $changed; | ||
1481 : | } | ||
1482 : | |||
1483 : | # | ||
1484 : | # Format the list of diagrams that a subsystem has. | ||
1485 : | # | ||
1486 : | |||
1487 : | sub format_diagrams | ||
1488 : | { | ||
1489 : | my($fig, $cgi, $html, $subsystem, $can_alter) = @_; | ||
1490 : | |||
1491 : | my @diagrams = $subsystem->get_diagrams(); | ||
1492 : | |||
1493 : | if (@diagrams or $can_alter) | ||
1494 : | { | ||
1495 : | push(@$html, $cgi->hr, $cgi->h2("Subsystem Diagrams")); | ||
1496 : | } | ||
1497 : | |||
1498 : | if (@diagrams) | ||
1499 : | { | ||
1500 : | my @hdr = ("Diagram Name"); | ||
1501 : | |||
1502 : | if ($can_alter) | ||
1503 : | { | ||
1504 : | push(@hdr, "Delete", "Rename"); | ||
1505 : | } | ||
1506 : | |||
1507 : | my @tbl; | ||
1508 : | for my $dent (@diagrams) | ||
1509 : | { | ||
1510 : | my($id, $name, $link) = @$dent; | ||
1511 : | my @row; | ||
1512 : | |||
1513 : | push(@row, qq(<a href="$link" target="show_ss_diagram_$id">$name</a>)); | ||
1514 : | |||
1515 : | if ($can_alter) | ||
1516 : | { | ||
1517 : | push(@row, $cgi->checkbox(-name => "diagram_delete_$id", -label => "", | ||
1518 : | -value => undef, | ||
1519 : | -override => 1)); | ||
1520 : | push(@row, $cgi->textfield(-name => "diagram_rename_$id", | ||
1521 : | -value => "", | ||
1522 : | -override => 1)); | ||
1523 : | } | ||
1524 : | |||
1525 : | push(@tbl, \@row); | ||
1526 : | } | ||
1527 : | push(@$html, &HTML::make_table(\@hdr, \@tbl)); | ||
1528 : | } | ||
1529 : | |||
1530 : | if ($can_alter) | ||
1531 : | { | ||
1532 : | my @tbl; | ||
1533 : | |||
1534 : | push(@tbl, ["Diagram name:", $cgi->textfield(-name => "diagram_new_name", | ||
1535 : | -value => "", | ||
1536 : | -override => 1, | ||
1537 : | -size => 30)]); | ||
1538 : | push(@tbl, ["Diagram image file:", $cgi->filefield(-name => "diagram_image_file", | ||
1539 : | -size => 50)]); | ||
1540 : | push(@$html, &HTML::make_table(undef, \@tbl)); | ||
1541 : | |||
1542 : | push(@$html, $cgi->submit(-name => 'diagram_action', | ||
1543 : | -label => 'Process diagram actions')); | ||
1544 : | } | ||
1545 : | push(@$html, $cgi->hr); | ||
1546 : | } | ||
1547 : | |||
1548 : | sub tree_link { | ||
1549 : | my $target = "window$$"; | ||
1550 : | my $url = &FIG::cgi_url . "/subsys_hope.cgi?request=show_tree"; | ||
1551 : | return "<a href=$url target=$target>Show Phylogenetic Tree</a>"; | ||
1552 : | } | ||
1553 : | |||
1554 : | |||
1555 : | # There is a lot of blood, sweat and tears that go into computing the active | ||
1556 : | # set of rows. This is useful information to have later, when the user can | ||
1557 : | # select genomes to be checked. We will return the genome list as a reference | ||
1558 : | # to a list of [ genomme_number => name ] pairs. -- GJO | ||
1559 : | |||
1560 : | sub format_rows { | ||
1561 : | my($fig,$cgi,$html,$subsystem, $tagvalcolor) = @_; | ||
1562 : | my($i,%alternatives); | ||
1563 : | my $active_genome_list = []; | ||
1564 : | |||
1565 : | my $ignore_alt = $cgi->param('ignore_alt'); | ||
1566 : | |||
1567 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
1568 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
1569 : | |||
1570 : | # RAE: | ||
1571 : | # added this to allow determination of an active_subsetR based on a tag value pair | ||
1572 : | if ($cgi->param('active_key')) | ||
1573 : | { | ||
1574 : | $active_subsetR = $cgi->param('active_key'); | ||
1575 : | my $active_value = undef; | ||
1576 : | $active_value = $cgi->param('active_value') if ($cgi->param('active_value')); | ||
1577 : | $subsystem->load_row_subsets_by_kv($active_subsetR, $active_value); | ||
1578 : | $subsystem->set_active_subsetR($active_subsetR); | ||
1579 : | } | ||
1580 : | |||
1581 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
1582 : | my %activeC = map { $_ => 1 } @subsetC; | ||
1583 : | |||
1584 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
1585 : | my %activeR = map { $_ => 1 } @subsetR; | ||
1586 : | |||
1587 : | if (! $ignore_alt) | ||
1588 : | { | ||
1589 : | my $subset; | ||
1590 : | foreach $subset (grep { $_ =~ /^\*/ } $subsystem->get_subset_namesC) | ||
1591 : | { | ||
1592 : | my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($subset); | ||
1593 : | if (@mem > 1) | ||
1594 : | { | ||
1595 : | my $mem = [@mem]; | ||
1596 : | foreach $_ (@mem) | ||
1597 : | { | ||
1598 : | $alternatives{$_} = [$subset,$mem]; | ||
1599 : | } | ||
1600 : | } | ||
1601 : | } | ||
1602 : | } | ||
1603 : | |||
1604 : | my @in = $subsystem->get_genomes; | ||
1605 : | |||
1606 : | if (@in > 0) | ||
1607 : | { | ||
1608 : | my $col_hdrs = ["Genome ID","Organism","Variant Code"]; | ||
1609 : | |||
1610 : | if ($cgi->param('color_by_ga')) {push @{$col_hdrs}, "Attribute"} | ||
1611 : | |||
1612 : | my @row_guide = (); | ||
1613 : | |||
1614 : | # Add pop-up tool tip with role name to abbreviations in column header | ||
1615 : | # (a wonderful suggestion from Carl Woese). -- GJO | ||
1616 : | |||
1617 : | my( $role, %in_col, $abbrev, $mem, $abbrev_html ); | ||
1618 : | foreach $role (grep { $activeC{$_} } $subsystem->get_roles) | ||
1619 : | { | ||
1620 : | if ( ! $in_col{ $role } ) # Make sure the role is not already done | ||
1621 : | { | ||
1622 : | if ( $_ = $alternatives{ $role } ) | ||
1623 : | { | ||
1624 : | ( $abbrev, $mem ) = @$_; | ||
1625 : | push( @row_guide, [ map { [ $_, "-" . ($subsystem->get_role_index($_) + 1) ] } @$mem ] ); | ||
1626 : | foreach $_ ( @$mem ) { $in_col{ $_ } = 1 }; # Mark the roles that are done | ||
1627 : | my $rolelist = join '<br>', map { substr($_->[1],1) . ". $_->[0]" } @{$row_guide[-1]}; | ||
1628 : | $abbrev_html = "<a " . FIGjs::mouseover("Roles of $abbrev", $rolelist, '') . ">$abbrev</a>"; | ||
1629 : | push( @$col_hdrs, $abbrev_html ); | ||
1630 : | } | ||
1631 : | else | ||
1632 : | { | ||
1633 : | push( @row_guide, [ [ $role, "" ] ] ); # No suffix on peg number | ||
1634 : | $abbrev = $subsystem->get_role_abbr( $subsystem->get_role_index( $role ) ); | ||
1635 : | $abbrev_html = "<a " . FIGjs::mouseover("Role of $abbrev", $role, '') . ">$abbrev</a>"; | ||
1636 : | push( @$col_hdrs, $abbrev_html ); | ||
1637 : | } | ||
1638 : | } | ||
1639 : | } | ||
1640 : | |||
1641 : | my $tab = []; | ||
1642 : | my($genome,@pegs,@cells,$set,$peg_set,$pair,$role,$suffix,$row,$peg,$color_of,$cell,%count,$color,@colors); | ||
1643 : | |||
1644 : | # | ||
1645 : | # Simplified code for checking variants -- GJO | ||
1646 : | # If specific variants are requested, make a hash of those to keep: | ||
1647 : | # | ||
1648 : | my $variant_list = undef; | ||
1649 : | if ( $cgi->param( 'include_these_variants' ) ) | ||
1650 : | { | ||
1651 : | $variant_list = { map { ($_, 1) } split( /\s*,\s*/, $cgi->param( 'include_these_variants' ) ) }; | ||
1652 : | } | ||
1653 : | |||
1654 : | foreach $genome (grep { $activeR{$_} } @in) | ||
1655 : | { | ||
1656 : | my($genomeV,$vcodeV,$vcode_value); | ||
1657 : | |||
1658 : | # Get (and if necessary check) the variant code: | ||
1659 : | |||
1660 : | $vcode_value = $subsystem->get_variant_code( $subsystem->get_genome_index( $genome ) ); | ||
1661 : | next if ( $variant_list && ( ! $variant_list->{ $vcode_value } ) ); | ||
1662 : | |||
1663 : | $row = [ $genome, &ext_genus_species($fig,$genome), $vcode_value ]; | ||
1664 : | push @$active_genome_list, [ $row->[0], $row->[1] ]; # Save a list of the active genomes | ||
1665 : | |||
1666 : | @pegs = (); | ||
1667 : | @cells = (); | ||
1668 : | |||
1669 : | foreach $set (@row_guide) | ||
1670 : | { | ||
1671 : | $peg_set = []; | ||
1672 : | foreach $pair (@$set) | ||
1673 : | { | ||
1674 : | ($role,$suffix) = @$pair; | ||
1675 : | foreach $peg ($subsystem->get_pegs_from_cell($genome,$role)) | ||
1676 : | { | ||
1677 : | push(@$peg_set,[$peg,$suffix]); | ||
1678 : | } | ||
1679 : | } | ||
1680 : | push(@pegs,map { $_->[0] } @$peg_set); | ||
1681 : | push(@cells,$peg_set); | ||
1682 : | } | ||
1683 : | $color_of = &group_by_clusters($fig,\@pegs); | ||
1684 : | # RAE added a new call to get tag/value pairs | ||
1685 : | # Note that $color_of is not overwritten. | ||
1686 : | my $superscript; | ||
1687 : | if ($cgi->param('color_by_ga')) | ||
1688 : | { | ||
1689 : | # add colors based on the genome attributes | ||
1690 : | # get the value | ||
1691 : | my $ga=$cgi->param('color_by_ga'); | ||
1692 : | my $valuetype=$fig->guess_value_format($ga); | ||
1693 : | my @array=$fig->get_attributes($genome, $ga); | ||
1694 : | unless ($array[0]) {$array[0]=[]} | ||
1695 : | # for the purposes of this page, we are going to color on the | ||
1696 : | # value of the last attribute | ||
1697 : | my ($gotpeg, $gottag, $value, $url)=@{$array[0]}; | ||
1698 : | if (defined $value) # we don't want to color undefined values | ||
1699 : | { | ||
1700 : | my @color=&cool_colors(); | ||
1701 : | my $colval; # what we are basing the color on. | ||
1702 : | if ($valuetype->[0] eq "string") {$colval=$value} # strings are easy, we color based on string; | ||
1703 : | else { | ||
1704 : | # Initially spllit numbers into groups of 10. | ||
1705 : | # $valuetype->[2] is the maximum number for this value | ||
1706 : | # but I don't like this | ||
1707 : | # $colval = int($value/$valuetype->[2]*10); | ||
1708 : | |||
1709 : | # we want something like 0-1, 1-2, 2-3, 3-4 as the labels. | ||
1710 : | # so we will do it in groups of ten | ||
1711 : | my ($type, $min, $max)=@$valuetype; | ||
1712 : | for (my $i=$min; $i<$max; $i+=$max/10) { | ||
1713 : | if ($value >= $i && $value < $i+$max/10) {$colval = $i . "-" . ($i+($max/10))} | ||
1714 : | } | ||
1715 : | } | ||
1716 : | |||
1717 : | if (!$tagvalcolor->{$colval}) { | ||
1718 : | # figure out the highest number used in the array | ||
1719 : | $tagvalcolor->{$colval}=0; | ||
1720 : | foreach my $t (keys %$tagvalcolor) { | ||
1721 : | ($tagvalcolor->{$t} > $tagvalcolor->{$colval}) ? $tagvalcolor->{$colval}=$tagvalcolor->{$t} : 1; | ||
1722 : | } | ||
1723 : | $tagvalcolor->{$colval}++; | ||
1724 : | } | ||
1725 : | |||
1726 : | # RAE Add a column for the description | ||
1727 : | splice @$row, 3, 0, $colval; | ||
1728 : | |||
1729 : | foreach my $cell (@cells) { | ||
1730 : | foreach $_ (@$cell) | ||
1731 : | { | ||
1732 : | $color_of->{$_->[0]} = $color[$tagvalcolor->{$colval}] | ||
1733 : | } | ||
1734 : | } | ||
1735 : | } | ||
1736 : | else | ||
1737 : | { | ||
1738 : | # RAE Add a column for the description | ||
1739 : | splice @$row, 3, 0, " "; | ||
1740 : | } | ||
1741 : | } | ||
1742 : | if ($cgi->param("color_by_peg_tag")) | ||
1743 : | { | ||
1744 : | ($color_of, $superscript, $tagvalcolor) = color_by_tag($fig, \@pegs, $color_of, $tagvalcolor, $cgi->param("color_by_peg_tag")); | ||
1745 : | } | ||
1746 : | foreach $cell ( @cells ) # $cell = [peg, suffix] | ||
1747 : | { | ||
1748 : | # Deal with the trivial case (no pegs) at the start | ||
1749 : | |||
1750 : | if ( ! @$cell ) | ||
1751 : | { | ||
1752 : | # Push an empty cell onto the row | ||
1753 : | |||
1754 : | push @$row, '@bgcolor="#FFFFFF": '; | ||
1755 : | next; | ||
1756 : | } | ||
1757 : | |||
1758 : | # Figure out html text for each peg and cluster by color. | ||
1759 : | |||
1760 : | my ( $peg, $suffix, $txt, $color ); | ||
1761 : | my @colors = (); | ||
1762 : | my %text_by_color; # Gather like-colored peg text | ||
1763 : | foreach ( @$cell ) | ||
1764 : | { | ||
1765 : | ( $peg, $suffix ) = @$_; | ||
1766 : | # Hyperlink each peg, and add its suffix: | ||
1767 : | $txt = ( $cgi->param('ext_ids') ? external_id($fig,$cgi,$peg) | ||
1768 : | : HTML::fid_link($cgi,$peg, "local") ) | ||
1769 : | . ( $suffix ? $suffix : '' ); | ||
1770 : | $color = $color_of->{ $peg }; | ||
1771 : | defined( $text_by_color{ $color } ) or push @colors, $color; | ||
1772 : | push @{ $text_by_color{ $color } }, $txt; | ||
1773 : | } | ||
1774 : | my $ncolors = @colors; | ||
1775 : | |||
1776 : | # Join text strings within a color (and remove last comma): | ||
1777 : | |||
1778 : | my @str_by_color = map { [ $_, join( ', ', @{ $text_by_color{$_} }, '' ) ] } @colors; | ||
1779 : | $str_by_color[-1]->[1] =~ s/, $//; | ||
1780 : | |||
1781 : | # Build the "superscript" string: | ||
1782 : | |||
1783 : | my $sscript = ""; | ||
1784 : | if ( $superscript && @$cell ) | ||
1785 : | { | ||
1786 : | my ( %sscript, $ss ); | ||
1787 : | foreach my $cv ( @$cell ) # Should this be flattened across all pegs? | ||
1788 : | { | ||
1789 : | next unless ( $ss = $superscript->{ $cv->[0] } ); | ||
1790 : | # my %flatten = map { ( $_, 1 ) } @$ss; | ||
1791 : | # $sscript{ join ",", sort { $a <=> $b } keys %flatten } = 1; # string of all values for peg | ||
1792 : | foreach ( @$ss ) { $sscript{ $_ } = 1 } | ||
1793 : | } | ||
1794 : | if (scalar keys %sscript) # order by number, and format | ||
1795 : | { | ||
1796 : | my @ss = map { $_->[0] } | ||
1797 : | sort { $a->[1] <=> $b->[1] } | ||
1798 : | map { my ( $num ) = $_ =~ /\>(\d+)\</; [ $_, $num || 0 ] } keys %sscript; | ||
1799 : | $sscript = " <sup>[" . join( ", ", @ss ) . "]</sup>" | ||
1800 : | } | ||
1801 : | } | ||
1802 : | |||
1803 : | my $cell_data; | ||
1804 : | |||
1805 : | # If there is one color, just write a unicolor cell. | ||
1806 : | |||
1807 : | if ( $ncolors == 1 ) | ||
1808 : | { | ||
1809 : | my ( $color, $txt ) = @{ shift @str_by_color }; | ||
1810 : | $cell_data = qq(\@bgcolor="$color":) . $txt . $sscript; | ||
1811 : | } | ||
1812 : | |||
1813 : | # Otherwise, write pegs into a subtable with one cell per color. | ||
1814 : | |||
1815 : | else | ||
1816 : | { | ||
1817 : | $cell_data = '<table><tr valign=bottom>' | ||
1818 : | . join( '', map { ( $color, $txt ) = @$_ ; qq(<td bgcolor="$color">$txt</td>) } @str_by_color ) | ||
1819 : | . ( $sscript ? "<td>$sscript</td>" : '' ) | ||
1820 : | . '</tr></table>'; | ||
1821 : | } | ||
1822 : | |||
1823 : | # Push the cell data onto the row: | ||
1824 : | |||
1825 : | push(@$row, $cell_data); | ||
1826 : | } | ||
1827 : | push(@$tab,$row); | ||
1828 : | } | ||
1829 : | |||
1830 : | |||
1831 : | my($sort); | ||
1832 : | if ($sort = $cgi->param('sort')) | ||
1833 : | { | ||
1834 : | if ($sort eq "by_pattern") | ||
1835 : | { | ||
1836 : | my @tmp = (); | ||
1837 : | my $row; | ||
1838 : | foreach $row (@$tab) | ||
1839 : | { | ||
1840 : | my @var = (); | ||
1841 : | my $i; | ||
1842 : | for ($i=3; ($i < @$row); $i++) | ||
1843 : | { | ||
1844 : | push(@var, ($row->[$i] =~ /\|/) ? 1 : 0); | ||
1845 : | } | ||
1846 : | push(@tmp,[join("",@var),$row]); | ||
1847 : | } | ||
1848 : | $tab = [map { $_->[1] } sort { $a->[0] cmp $b->[0] } @tmp]; | ||
1849 : | } | ||
1850 : | elsif ($sort eq "by_phylo") | ||
1851 : | { | ||
1852 : | $tab = [map { $_->[0] } | ||
1853 : | sort { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) } | ||
1854 : | map { [$_, $fig->taxonomy_of($_->[0])] } | ||
1855 : | @$tab]; | ||
1856 : | } | ||
1857 : | elsif ($sort eq "by_tax_id") | ||
1858 : | { | ||
1859 : | $tab = [sort { $a->[0] <=> $b->[0] } @$tab]; | ||
1860 : | } | ||
1861 : | elsif ($sort eq "alphabetic") | ||
1862 : | { | ||
1863 : | $tab = [sort { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @$tab]; | ||
1864 : | } | ||
1865 : | elsif ($sort eq "by_variant") | ||
1866 : | { | ||
1867 : | $tab = [sort { ($a->[2] cmp $b->[2]) or ($a->[1] <=> $b->[1]) } @$tab]; | ||
1868 : | } | ||
1869 : | } | ||
1870 : | |||
1871 : | foreach $row (@$tab) | ||
1872 : | { | ||
1873 : | next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked | ||
1874 : | my($genomeV,$vcodeV,$vcode_value); | ||
1875 : | $genome = $row->[0]; | ||
1876 : | $vcode_value = $row->[2]; | ||
1877 : | if ($cgi->param('can_alter')) | ||
1878 : | { | ||
1879 : | $genomeV = $cgi->textfield(-name => "genome$genome", -size => 15, -value => $genome, -override => 1); | ||
1880 : | $vcodeV = $cgi->textfield(-name => "vcode$genome", -value => $vcode_value, -size => 10); | ||
1881 : | } | ||
1882 : | else | ||
1883 : | { | ||
1884 : | push(@$html,$cgi->hidden(-name => "genome$genome", -value => $genome, -override => 1), | ||
1885 : | $cgi->hidden(-name => "vcode$genome", -value => $vcode_value)); | ||
1886 : | $genomeV = $genome; | ||
1887 : | $vcodeV = $vcode_value; | ||
1888 : | } | ||
1889 : | $row->[0] = $genomeV; | ||
1890 : | $row->[2] = $vcodeV; | ||
1891 : | } | ||
1892 : | |||
1893 : | my $tab1 = []; | ||
1894 : | |||
1895 : | foreach $row (@$tab) | ||
1896 : | { | ||
1897 : | next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked | ||
1898 : | if ((@$tab1 > 0) && ((@$tab1 % 10) == 0)) | ||
1899 : | { | ||
1900 : | push(@$tab1,[map { "<b>$_</b>" } @$col_hdrs]) ; | ||
1901 : | } | ||
1902 : | push(@$tab1,$row); | ||
1903 : | } | ||
1904 : | |||
1905 : | push(@$html,&HTML::make_table($col_hdrs,$tab1,"Basic Spreadsheet"), | ||
1906 : | $cgi->hr | ||
1907 : | ); | ||
1908 : | |||
1909 : | push(@$html,$cgi->scrolling_list(-name => 'sort', | ||
1910 : | -value => ['unsorted','alphabetic','by_pattern', | ||
1911 : | 'by_phylo','by_tax_id','by_variant'], | ||
1912 : | -default => 'unsorted' | ||
1913 : | )); | ||
1914 : | |||
1915 : | push(@$html,'<br><br>Enter comma-separated list of variants to display in spreadsheet<br>', | ||
1916 : | $cgi->textfield(-name => "include_these_variants", -size => 50) | ||
1917 : | ); | ||
1918 : | } | ||
1919 : | |||
1920 : | # add an explanation for the colors if we want one. | ||
1921 : | if ($cgi->param('color_by_ga')) | ||
1922 : | { | ||
1923 : | push(@$html, &HTML::make_table(undef,&describe_colors($tagvalcolor),"Color Descriptions<br><small>Link limits display to those organisms</small>")); | ||
1924 : | } | ||
1925 : | |||
1926 : | return $active_genome_list; # [ [ id1, gs1 ], [ id2, gs2 ], ... ] | ||
1927 : | } | ||
1928 : | |||
1929 : | |||
1930 : | sub group_by_clusters { | ||
1931 : | my($fig,$pegs) = @_; | ||
1932 : | my($peg,@clusters,@cluster,@colors,$color,%seen,%conn,$x,$peg1,@pegs,$i); | ||
1933 : | |||
1934 : | my $color_of = {}; | ||
1935 : | foreach $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' } | ||
1936 : | |||
1937 : | if ($cgi->param('show_clusters')) | ||
1938 : | { | ||
1939 : | @pegs = keys(%$color_of); # Use of keys makes @pegs entries unique | ||
1940 : | |||
1941 : | foreach $peg (@pegs) | ||
1942 : | { | ||
1943 : | foreach $peg1 (grep { $color_of->{$_} && ($_ ne $peg) } $fig->close_genes($peg,5000)) | ||
1944 : | { | ||
1945 : | push(@{$conn{$peg}},$peg1); | ||
1946 : | } | ||
1947 : | } | ||
1948 : | |||
1949 : | @clusters = (); | ||
1950 : | while ($peg = shift @pegs) | ||
1951 : | { | ||
1952 : | if (! $seen{$peg}) | ||
1953 : | { | ||
1954 : | @cluster = ($peg); | ||
1955 : | $seen{$peg} = 1; | ||
1956 : | for ($i=0; ($i < @cluster); $i++) | ||
1957 : | { | ||
1958 : | $x = $conn{$cluster[$i]}; | ||
1959 : | foreach $peg1 (@$x) | ||
1960 : | { | ||
1961 : | if (! $seen{$peg1}) | ||
1962 : | { | ||
1963 : | push(@cluster,$peg1); | ||
1964 : | $seen{$peg1} = 1; | ||
1965 : | } | ||
1966 : | } | ||
1967 : | } | ||
1968 : | push(@clusters,[@cluster]); | ||
1969 : | } | ||
1970 : | } | ||
1971 : | |||
1972 : | @colors = &cool_colors(); | ||
1973 : | |||
1974 : | @clusters = grep { @$_ > 1 } sort { @$a <=> @$b } @clusters; | ||
1975 : | |||
1976 : | if (@clusters > @colors) { splice(@clusters,0,(@clusters - @colors)) } # make sure we have enough colors | ||
1977 : | |||
1978 : | my($cluster); | ||
1979 : | foreach $cluster (@clusters) | ||
1980 : | { | ||
1981 : | $color = shift @colors; | ||
1982 : | foreach $peg (@$cluster) | ||
1983 : | { | ||
1984 : | $color_of->{$peg} = $color; | ||
1985 : | } | ||
1986 : | } | ||
1987 : | } | ||
1988 : | return $color_of; | ||
1989 : | } | ||
1990 : | |||
1991 : | |||
1992 : | =head1 color_by_tag | ||
1993 : | |||
1994 : | Change the color of cells by the pir superfamily. This is taken from the key/value pair | ||
1995 : | Note that we will not change the color if $cgi->param('show_clusters') is set. | ||
1996 : | |||
1997 : | This is gneric and takes the following arguments: | ||
1998 : | fig, | ||
1999 : | pointer to list of pegs, | ||
2000 : | pointer to hash of colors by peg, | ||
2001 : | pointer to a hash that retains numbers across rows. The number is based on the value. | ||
2002 : | tag to use in encoding | ||
2003 : | |||
2004 : | eg. ($color_of, $superscript, $tagvalcolor) = color_by_tag($fig, $pegs, $color_of, $tagvalcolor, "PIRSF"); | ||
2005 : | |||
2006 : | =cut | ||
2007 : | |||
2008 : | sub color_by_tag { | ||
2009 : | # RAE added this so we can color individual cells across a column | ||
2010 : | my ($fig, $pegs, $color_of, $tagvalcolor, $want)=@_; | ||
2011 : | # figure out the colors and the superscripts for the pirsf | ||
2012 : | # superscript will be a number | ||
2013 : | # color will be related to the number somehow | ||
2014 : | # url will be the url for each number | ||
2015 : | my $number; my $url; | ||
2016 : | my $count=0; | ||
2017 : | #count has to be the highest number if we increment it | ||
2018 : | foreach my $t (keys %$tagvalcolor) {($tagvalcolor->{$t} > $count) ? $count=$tagvalcolor->{$t} : 1} | ||
2019 : | $count++; # this should now be the next number to assign | ||
2020 : | foreach my $peg (@$pegs) { | ||
2021 : | next unless (my @attr=$fig->get_attributes($peg)); | ||
2022 : | foreach my $attr (@attr) { | ||
2023 : | next unless (defined $attr); | ||
2024 : | my ($gotpeg, $tag, $val, $link)=@$attr; | ||
2025 : | next unless ($tag eq $want); | ||
2026 : | if ($tagvalcolor->{$val}) { | ||
2027 : | $number->{$peg}=$tagvalcolor->{$val}; | ||
2028 : | push (@{$url->{$peg}}, "<a href='$link'>" . $number->{$peg} . "</a>"); | ||
2029 : | } | ||
2030 : | else { | ||
2031 : | $number->{$peg}=$tagvalcolor->{$val}=$count++; | ||
2032 : | push (@{$url->{$peg}}, "<a href='$link'>" . $number->{$peg} . "</a>"); | ||
2033 : | } | ||
2034 : | #### This is a botch at the moment. I want PIRSF to go to my page that I am working on, not PIR | ||
2035 : | #### so I am just correcting those. This is not good, and I should change the urls in the tag/value pairs or something | ||
2036 : | if ($want eq "PIRSF") { | ||
2037 : | pop @{$url->{$peg}}; | ||
2038 : | $val =~ /(^PIRSF\d+)/; | ||
2039 : | push (@{$url->{$peg}}, $cgi->a({href => "pir.cgi?&user=$user&pirsf=$1"}, $number->{$peg})); | ||
2040 : | } | ||
2041 : | } | ||
2042 : | } | ||
2043 : | |||
2044 : | |||
2045 : | # if we want to assign some colors, lets do so now | ||
2046 : | my @colors = &cool_colors(); | ||
2047 : | unless ($cgi->param('show_clusters')) { | ||
2048 : | foreach my $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' } | ||
2049 : | foreach my $peg (keys %$number) { | ||
2050 : | # the color is going to be the location in @colors | ||
2051 : | unless ($number->{$peg} > @colors) {$color_of->{$peg}=$colors[$number->{$peg}-1]} | ||
2052 : | } | ||
2053 : | } | ||
2054 : | return ($color_of, $url, $tagvalcolor); | ||
2055 : | } | ||
2056 : | |||
2057 : | |||
2058 : | sub format_ssa_table { | ||
2059 : | my($cgi,$html,$user,$ssaP) = @_; | ||
2060 : | my($ssa,$curator); | ||
2061 : | my($url1,$link1); | ||
2062 : | |||
2063 : | my $can_alter = $cgi->param('can_alter'); | ||
2064 : | push(@$html, $cgi->start_form(-action => "subsys_hope.cgi", | ||
2065 : | -method => 'post'), | ||
2066 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
2067 : | $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1), | ||
2068 : | $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1) | ||
2069 : | ); | ||
2070 : | push(@$html,"<font size=\"+2\">Please do not ever edit someone else\'s spreadsheet (by using their | ||
2071 : | user ID), and <b>never open multiple windows to | ||
2072 : | process the same spreadsheet</b></font>. It is, of course, standard practice to open a subsystem | ||
2073 : | spreadsheet and then to have multiple other SEED windows to access data and modify annotations. Further, | ||
2074 : | you can access someone else's subsystem spreadsheet using your ID (which will make it impossible | ||
2075 : | for you to edit the spreadsheet). | ||
2076 : | Just do not open the same subsystem spreadsheet for editing in multiple windows simultaneously. | ||
2077 : | A gray color means that the subsystem has no genomes attached to it. Go ahead and make these your own\n", | ||
2078 : | "<a href=\"/FIG/Html/conflict_resolution.html\" class=\"help\" target=\"help\">Help on conflict resolution</a>\n", | ||
2079 : | $cgi->br, | ||
2080 : | $cgi->br | ||
2081 : | ); | ||
2082 : | |||
2083 : | # RAE: removed this from above push because VV want's it kept secret | ||
2084 : | # "<a href=\"/FIG/Html/seedtips.html#change_ownership\" class=\"help\" target=\"help\">Help on changing subsystem ownership</a>\n", | ||
2085 : | |||
2086 : | # RAE: Added a new cgi param colsort for sort by column. This url will just recall the script with username to allow column sorting. | ||
2087 : | # RAE: Added a column to allow indexing of one subsystem. This is also going to be used in the renaming of a subsystem, too | ||
2088 : | |||
2089 : | my $col_hdrs = [ | ||
2090 : | "<a href='" . &FIG::cgi_url . "/subsys_hope.cgi?user=$user'>Name</a><br><small>Sort by Subsystem</small>", | ||
2091 : | "<a href='" . &FIG::cgi_url . "/subsys_hope.cgi?user=$user&colsort=curator'>Curator</a><br><small>Sort by curator</small>", | ||
2092 : | "Exchangable","Version", | ||
2093 : | "Reset to Previous Timestamp","Delete", | ||
2094 : | "Export Full Subsystem","Export Just Assignments", "Publish to Clearinghouse", "Reindex Subsystem", | ||
2095 : | ]; | ||
2096 : | my $title = "Existing Subsystem Annotations"; | ||
2097 : | my $tab = []; | ||
2098 : | foreach $_ (@$ssaP) | ||
2099 : | { | ||
2100 : | my($publish_checkbox, $index_checkbox); | ||
2101 : | ($ssa,$curator) = @$_; | ||
2102 : | |||
2103 : | my $esc_ssa = uri_escape($ssa); | ||
2104 : | |||
2105 : | my($url,$link); | ||
2106 : | if ((-d "$FIG_Config::data/Subsystems/$ssa/Backup") && ($curator eq $cgi->param('user'))) | ||
2107 : | { | ||
2108 : | $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=reset"; | ||
2109 : | $link = "<a href=$url>reset</a>"; | ||
2110 : | } | ||
2111 : | else | ||
2112 : | { | ||
2113 : | $link = ""; | ||
2114 : | } | ||
2115 : | |||
2116 : | if (($fig->is_exchangable_subsystem($ssa)) && ($curator eq $cgi->param('user'))) | ||
2117 : | { | ||
2118 : | $url1 = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=make_unexchangable"; | ||
2119 : | $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>"; | ||
2120 : | } | ||
2121 : | elsif ($curator eq $cgi->param('user')) | ||
2122 : | { | ||
2123 : | $url1 = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=make_exchangable"; | ||
2124 : | $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>"; | ||
2125 : | } | ||
2126 : | else | ||
2127 : | { | ||
2128 : | $link1 = ""; | ||
2129 : | } | ||
2130 : | |||
2131 : | # | ||
2132 : | # Only allow publish for subsystems we are curating? | ||
2133 : | # | ||
2134 : | if ($curator eq $cgi->param('user')) | ||
2135 : | { | ||
2136 : | $publish_checkbox = $cgi->checkbox(-name => "publish_to_clearinghouse", | ||
2137 : | -value => $ssa, | ||
2138 : | -label => "Publish"); | ||
2139 : | |||
2140 : | } | ||
2141 : | |||
2142 : | # | ||
2143 : | # Initially I am going to allow indexing of any subsystem since you may want to index it to allow | ||
2144 : | # better searhing on a local system | ||
2145 : | $index_checkbox=$cgi->checkbox(-name => "index_subsystem", -value=> $ssa, -label => "Index"); | ||
2146 : | |||
2147 : | # RAE color the background if the subsystem is empty | ||
2148 : | # this uses a modification to HTML.pm that I made earlier to accept refs to arrays as cell data | ||
2149 : | my $cell1=&ssa_link($fig,$ssa,$user); | ||
2150 : | #unless (scalar $fig->subsystem_to_roles($ssa)) {$cell1 = [$cell1, 'td bgcolor="Dark grey"']} ## THIS IS DOG SLOW, BUT WORKS | ||
2151 : | #unless (scalar $fig->get_subsystem($ssa)->get_genomes()) {$cell1 = [$cell1, 'td bgcolor="#A9A9A9"']} ## WORKS PERFECTLY, but sort of slow | ||
2152 : | unless (scalar @{$fig->subsystem_genomes($ssa, 1)}) {$cell1 = [$cell1, 'td bgcolor="silver"']} | ||
2153 : | |||
2154 : | push(@$tab,[ | ||
2155 : | $cell1, | ||
2156 : | $curator, | ||
2157 : | $link1, | ||
2158 : | $fig->subsystem_version($ssa), | ||
2159 : | $link, | ||
2160 : | ($curator eq $cgi->param('user')) ? $cgi->checkbox(-name => "delete", -value => $ssa) : "", | ||
2161 : | $cgi->checkbox(-name => "export", -value => $ssa, -label => "Export full"), | ||
2162 : | $cgi->checkbox(-name => "export_assignments", -value => $ssa, -label => "Export assignments"), | ||
2163 : | $publish_checkbox, $index_checkbox, | ||
2164 : | ]); | ||
2165 : | } | ||
2166 : | push(@$html, | ||
2167 : | &HTML::make_table($col_hdrs,$tab,$title), | ||
2168 : | $cgi->submit(-name => 'delete_export', | ||
2169 : | -label => 'Process marked deletions and exports'), | ||
2170 : | $cgi->submit(-name => 'publish', | ||
2171 : | -label => "Publish marked subsystems"), | ||
2172 : | $cgi->submit(-name => 'reindex', | ||
2173 : | -label => "Reindex selected subsystems"), | ||
2174 : | $cgi->end_form | ||
2175 : | ); | ||
2176 : | } | ||
2177 : | |||
2178 : | # RAE: I think this should be placed as a method in | ||
2179 : | # Subsystems.pm and called subsystems I know about or something. | ||
2180 : | # Cowardly didn't do though :-) | ||
2181 : | sub existing_subsystem_annotations { | ||
2182 : | my($fig) = @_; | ||
2183 : | my($ssa,$name); | ||
2184 : | my @ssa = (); | ||
2185 : | if (opendir(SSA,"$FIG_Config::data/Subsystems")) | ||
2186 : | { | ||
2187 : | @ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/[ \/]/_/g; [$name,$fig->subsystem_curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA); | ||
2188 : | closedir(SSA); | ||
2189 : | } | ||
2190 : | # RAE Adding sort of current subsystems | ||
2191 : | if ($cgi->param('colsort') && $cgi->param('colsort') eq "curator") | ||
2192 : | { | ||
2193 : | # sort by the ss curator | ||
2194 : | return sort { (lc $a->[1]) cmp (lc $b->[1]) || (lc $a->[0]) cmp (lc $b->[0]) } @ssa; | ||
2195 : | } | ||
2196 : | else | ||
2197 : | { | ||
2198 : | return sort { (lc $a->[0]) cmp (lc $b->[0]) } @ssa; | ||
2199 : | } | ||
2200 : | } | ||
2201 : | |||
2202 : | sub ssa_link { | ||
2203 : | my($fig,$ssa,$user) = @_; | ||
2204 : | my $name = $ssa; $name =~ s/_/ /g; | ||
2205 : | my $target = "window$$"; | ||
2206 : | if ($name =~ /([a-zA-Z]{3})/) | ||
2207 : | { | ||
2208 : | $target .= ".$1"; | ||
2209 : | } | ||
2210 : | |||
2211 : | my $check; | ||
2212 : | my $can_alter = $check = $fig->subsystem_curator($ssa) eq $user; | ||
2213 : | |||
2214 : | my $esc_ssa = uri_escape($ssa); | ||
2215 : | my $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=$esc_ssa&request=show_ssa&can_alter=$can_alter&check=$check&sort=by_phylo&show_clusters=1"; | ||
2216 : | return "<a href=$url target=$target>$name</a>"; | ||
2217 : | } | ||
2218 : | |||
2219 : | sub log_update { | ||
2220 : | my($ssa,$user) = @_; | ||
2221 : | |||
2222 : | $ssa =~ s/[ \/]/_/g; | ||
2223 : | |||
2224 : | if (open(LOG,">>$FIG_Config::data/Subsystems/$ssa/curation.log")) | ||
2225 : | { | ||
2226 : | my $time = time; | ||
2227 : | print LOG "$time\t$user\tupdated\n"; | ||
2228 : | close(LOG); | ||
2229 : | } | ||
2230 : | else | ||
2231 : | { | ||
2232 : | print STDERR "failed to open $FIG_Config::data/Subsystems/$ssa/curation.log\n"; | ||
2233 : | } | ||
2234 : | } | ||
2235 : | |||
2236 : | sub export { | ||
2237 : | my($fig,$cgi,$ssa) = @_; | ||
2238 : | my($line); | ||
2239 : | |||
2240 : | my ($exportable,$notes) = $fig->exportable_subsystem($ssa); | ||
2241 : | foreach $line (@$exportable,@$notes) | ||
2242 : | { | ||
2243 : | print $line; | ||
2244 : | } | ||
2245 : | } | ||
2246 : | |||
2247 : | sub export_assignments { | ||
2248 : | my($fig,$cgi,$ssa) = @_; | ||
2249 : | my(@roles,$i,$entry,$id,$user); | ||
2250 : | |||
2251 : | if (($user = $cgi->param('user')) && open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet")) | ||
2252 : | { | ||
2253 : | $user =~ s/^master://; | ||
2254 : | &FIG::verify_dir("$FIG_Config::data/Assignments/$user"); | ||
2255 : | my $who = $fig->subsystem_curator($ssa); | ||
2256 : | my $file = &FIG::epoch_to_readable(time) . ":$who:generated_from_subsystem_$ssa"; | ||
2257 : | |||
2258 : | if (open(OUT,">$FIG_Config::data/Assignments/$user/$file")) | ||
2259 : | { | ||
2260 : | while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) | ||
2261 : | { | ||
2262 : | chop; | ||
2263 : | push(@roles,$_); | ||
2264 : | } | ||
2265 : | while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) {} | ||
2266 : | while (defined($_ = <SSA>)) | ||
2267 : | { | ||
2268 : | chop; | ||
2269 : | my @flds = split(/\t/,$_); | ||
2270 : | my $genome = $flds[0]; | ||
2271 : | for ($i=2; ($i < @flds); $i++) | ||
2272 : | { | ||
2273 : | my @entries = split(/,/,$flds[$i]); | ||
2274 : | foreach $id (@entries) | ||
2275 : | { | ||
2276 : | my $peg = "fig|$genome.peg.$id"; | ||
2277 : | my $func = $fig->function_of($peg); | ||
2278 : | print OUT "$peg\t$func\n"; | ||
2279 : | } | ||
2280 : | } | ||
2281 : | } | ||
2282 : | close(OUT); | ||
2283 : | } | ||
2284 : | close(SSA); | ||
2285 : | } | ||
2286 : | } | ||
2287 : | |||
2288 : | sub format_missing { | ||
2289 : | my($fig,$cgi,$html,$subsystem) = @_; | ||
2290 : | my($org,$abr,$role,$missing); | ||
2291 : | |||
2292 : | $user = $cgi->param('user'); | ||
2293 : | |||
2294 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
2295 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
2296 : | |||
2297 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
2298 : | my %activeC = map { $_ => 1 } @subsetC; | ||
2299 : | |||
2300 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
2301 : | |||
2302 : | my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC; | ||
2303 : | my($set,$col,%in); | ||
2304 : | foreach $set (@alt_sets) | ||
2305 : | { | ||
2306 : | my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set); | ||
2307 : | foreach $col (@mem) | ||
2308 : | { | ||
2309 : | $in{$col} = $set; | ||
2310 : | } | ||
2311 : | } | ||
2312 : | push(@$html,$cgi->h1('To Check Missing Entries:')); | ||
2313 : | |||
2314 : | foreach $org (@subsetR) | ||
2315 : | { | ||
2316 : | my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in); | ||
2317 : | |||
2318 : | $missing = []; | ||
2319 : | foreach $role (@missing) | ||
2320 : | { | ||
2321 : | $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role)); | ||
2322 : | my $roleE = $cgi->escape($role); | ||
2323 : | |||
2324 : | my $link = "<a href=" . &FIG::cgi_url . "/pom.cgi?user=$user&request=find_in_org&role=$roleE&org=$org>$abr $role</a>"; | ||
2325 : | push(@$missing,$link); | ||
2326 : | } | ||
2327 : | |||
2328 : | if (@$missing > 0) | ||
2329 : | { | ||
2330 : | my $genus_species = &ext_genus_species($fig,$org); | ||
2331 : | push(@$html,$cgi->h2("$org: $genus_species")); | ||
2332 : | push(@$html,$cgi->ul($cgi->li($missing))); | ||
2333 : | } | ||
2334 : | } | ||
2335 : | } | ||
2336 : | |||
2337 : | sub columns_missing_entries { | ||
2338 : | my($cgi,$subsystem,$org,$roles,$in) = @_; | ||
2339 : | |||
2340 : | my $just_genome = $cgi->param('just_genome'); | ||
2341 : | if ($just_genome && ($just_genome =~ /(\d+\.\d+)/) && ($org != $1)) { return () } | ||
2342 : | |||
2343 : | my $just_col = $cgi->param('just_col'); | ||
2344 : | my(@really_missing) = (); | ||
2345 : | |||
2346 : | my($role,%missing_cols); | ||
2347 : | foreach $role (@$roles) | ||
2348 : | { | ||
2349 : | next if ($just_col && ($role ne $just_col)); | ||
2350 : | if ($subsystem->get_pegs_from_cell($org,$role) == 0) | ||
2351 : | { | ||
2352 : | $missing_cols{$role} = 1; | ||
2353 : | } | ||
2354 : | } | ||
2355 : | |||
2356 : | foreach $role (@$roles) | ||
2357 : | { | ||
2358 : | if ($missing_cols{$role}) | ||
2359 : | { | ||
2360 : | my($set); | ||
2361 : | if (($set = $in->{$role}) && (! $cgi->param('ignore_alt'))) | ||
2362 : | { | ||
2363 : | my @set = $subsystem->get_subsetC_roles($set); | ||
2364 : | |||
2365 : | my($k); | ||
2366 : | for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {} | ||
2367 : | if ($k == @set) | ||
2368 : | { | ||
2369 : | push(@really_missing,$role); | ||
2370 : | } | ||
2371 : | } | ||
2372 : | else | ||
2373 : | { | ||
2374 : | push(@really_missing,$role); | ||
2375 : | } | ||
2376 : | } | ||
2377 : | } | ||
2378 : | return @really_missing; | ||
2379 : | } | ||
2380 : | |||
2381 : | sub format_missing_including_matches | ||
2382 : | { | ||
2383 : | my($fig,$cgi,$html,$subsystem) = @_; | ||
2384 : | my($org,$abr,$role,$missing); | ||
2385 : | |||
2386 : | my $user = $cgi->param('user'); | ||
2387 : | |||
2388 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
2389 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
2390 : | |||
2391 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
2392 : | my %activeC = map { $_ => 1 } @subsetC; | ||
2393 : | |||
2394 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
2395 : | |||
2396 : | my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC; | ||
2397 : | my($set,$col,%in); | ||
2398 : | foreach $set (@alt_sets) | ||
2399 : | { | ||
2400 : | my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set); | ||
2401 : | foreach $col (@mem) | ||
2402 : | { | ||
2403 : | $in{$col} = $set; | ||
2404 : | } | ||
2405 : | } | ||
2406 : | push(@$html,$cgi->h1('To Check Missing Entries:')); | ||
2407 : | |||
2408 : | push(@$html, $cgi->start_form(-action=> "fid_checked.cgi")); | ||
2409 : | |||
2410 : | my $can_alter = $cgi->param('can_alter'); | ||
2411 : | push(@$html, | ||
2412 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
2413 : | $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1)); | ||
2414 : | |||
2415 : | my $just_role = &which_role($subsystem,$cgi->param('just_role')); | ||
2416 : | # print STDERR "There are ", scalar @subsetR, " organisms to check\n"; | ||
2417 : | foreach $org (@subsetR) | ||
2418 : | { | ||
2419 : | my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in); | ||
2420 : | $missing = []; | ||
2421 : | foreach $role (@missing) | ||
2422 : | { | ||
2423 : | # next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1))); | ||
2424 : | next if ($just_role && ($just_role ne $role)); | ||
2425 : | |||
2426 : | my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff")); | ||
2427 : | push(@$missing,@hits); | ||
2428 : | } | ||
2429 : | # print STDERR "Found ", scalar @$missing, " for $org\n"; | ||
2430 : | if (@$missing > 0) | ||
2431 : | { | ||
2432 : | my $genus_species = &ext_genus_species($fig,$org); | ||
2433 : | push(@$html,$cgi->h2("$org: $genus_species")); | ||
2434 : | |||
2435 : | my $colhdr = ["Assign", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"]; | ||
2436 : | my $tbl = []; | ||
2437 : | |||
2438 : | for my $hit (@$missing) | ||
2439 : | { | ||
2440 : | my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit; | ||
2441 : | |||
2442 : | my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1); | ||
2443 : | my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0); | ||
2444 : | |||
2445 : | my $checkbox = $cgi->checkbox(-name => "checked", | ||
2446 : | -value => "to=$my_peg,from=$match_peg", | ||
2447 : | -label => ""); | ||
2448 : | |||
2449 : | push(@$tbl, [$checkbox, | ||
2450 : | $psc, | ||
2451 : | $my_peg_link, $my_len, $my_fn, | ||
2452 : | $match_peg_link, $match_len, $match_fn]); | ||
2453 : | } | ||
2454 : | |||
2455 : | push(@$html, &HTML::make_table($colhdr, $tbl, "")); | ||
2456 : | } | ||
2457 : | } | ||
2458 : | push(@$html, | ||
2459 : | $cgi->submit(-value => "Process assignments", | ||
2460 : | -name => "batch_assign"), | ||
2461 : | $cgi->end_form); | ||
2462 : | } | ||
2463 : | |||
2464 : | |||
2465 : | |||
2466 : | sub columns_missing_entries { | ||
2467 : | my($cgi,$subsystem,$org,$roles,$in) = @_; | ||
2468 : | |||
2469 : | next if (($_ = $cgi->param('just_genome')) && ($org != $_)); | ||
2470 : | my $just_col = $cgi->param('just_col'); | ||
2471 : | my(@really_missing) = (); | ||
2472 : | |||
2473 : | my($role,%missing_cols); | ||
2474 : | foreach $role (@$roles) | ||
2475 : | { | ||
2476 : | next if ($just_col && ($role ne $just_col)); | ||
2477 : | if ($subsystem->get_pegs_from_cell($org,$role) == 0) | ||
2478 : | { | ||
2479 : | $missing_cols{$role} = 1; | ||
2480 : | } | ||
2481 : | } | ||
2482 : | |||
2483 : | foreach $role (@$roles) | ||
2484 : | { | ||
2485 : | if ($missing_cols{$role}) | ||
2486 : | { | ||
2487 : | my($set); | ||
2488 : | if (($set = $in->{$role}) && (! $cgi->param('ignore_alt'))) | ||
2489 : | { | ||
2490 : | my @set = $subsystem->get_subsetC_roles($set); | ||
2491 : | |||
2492 : | my($k); | ||
2493 : | for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {} | ||
2494 : | if ($k == @set) | ||
2495 : | { | ||
2496 : | push(@really_missing,$role); | ||
2497 : | } | ||
2498 : | } | ||
2499 : | else | ||
2500 : | { | ||
2501 : | push(@really_missing,$role); | ||
2502 : | } | ||
2503 : | } | ||
2504 : | } | ||
2505 : | return @really_missing; | ||
2506 : | } | ||
2507 : | |||
2508 : | sub format_missing_including_matches_in_ss | ||
2509 : | { | ||
2510 : | my($fig,$cgi,$html,$subsystem) = @_; | ||
2511 : | my($org,$abr,$role,$missing); | ||
2512 : | |||
2513 : | my $user = $cgi->param('user'); | ||
2514 : | |||
2515 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
2516 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
2517 : | |||
2518 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
2519 : | my %activeC = map { $_ => 1 } @subsetC; | ||
2520 : | |||
2521 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
2522 : | |||
2523 : | my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC; | ||
2524 : | my($set,$col,%in); | ||
2525 : | foreach $set (@alt_sets) | ||
2526 : | { | ||
2527 : | my @mem = grep { $activeC{$_} } $subsystem->get_subsetC_roles($set); | ||
2528 : | foreach $col (@mem) | ||
2529 : | { | ||
2530 : | $in{$col} = $set; | ||
2531 : | } | ||
2532 : | } | ||
2533 : | push(@$html,$cgi->h1('To Check Missing Entries:')); | ||
2534 : | |||
2535 : | push(@$html, $cgi->start_form(-action=> "fid_checked.cgi")); | ||
2536 : | |||
2537 : | my $can_alter = $cgi->param('can_alter'); | ||
2538 : | push(@$html, | ||
2539 : | $cgi->hidden(-name => 'user', -value => $user, -override => 1), | ||
2540 : | $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1)); | ||
2541 : | |||
2542 : | my $just_role = &which_role($subsystem,$cgi->param('just_role')); | ||
2543 : | |||
2544 : | foreach $org (@subsetR) | ||
2545 : | { | ||
2546 : | my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in); | ||
2547 : | $missing = []; | ||
2548 : | foreach $role (@missing) | ||
2549 : | { | ||
2550 : | # next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1))); | ||
2551 : | next if ($just_role && ($just_role ne $role)); | ||
2552 : | |||
2553 : | my $flag = 0; | ||
2554 : | my $filler; | ||
2555 : | my $rdbH = $fig->db_handle; | ||
2556 : | my $q = "SELECT subsystem, role FROM subsystem_index WHERE role = ?"; | ||
2557 : | if (my $relational_db_response = $rdbH->SQL($q, 0, $role)) | ||
2558 : | { | ||
2559 : | my $pair; | ||
2560 : | foreach $pair (@$relational_db_response) | ||
2561 : | { | ||
2562 : | my ($ss, $role) = @$pair; | ||
2563 : | #if($ss =="") | ||
2564 : | #{ | ||
2565 : | # $filler = 1; | ||
2566 : | #} | ||
2567 : | |||
2568 : | if ($ss !~/Unique/) | ||
2569 : | { | ||
2570 : | $flag = 1; | ||
2571 : | } | ||
2572 : | } | ||
2573 : | } | ||
2574 : | |||
2575 : | if ($flag == 1) | ||
2576 : | { | ||
2577 : | my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff")); | ||
2578 : | push(@$missing,@hits); | ||
2579 : | } | ||
2580 : | } | ||
2581 : | |||
2582 : | if (@$missing > 0) | ||
2583 : | { | ||
2584 : | my $genus_species = &ext_genus_species($fig,$org); | ||
2585 : | push(@$html,$cgi->h2("$org: $genus_species")); | ||
2586 : | |||
2587 : | my $colhdr = ["Assign","Sub(s)", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"]; | ||
2588 : | my $tbl = []; | ||
2589 : | |||
2590 : | for my $hit (@$missing) | ||
2591 : | { | ||
2592 : | my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit; | ||
2593 : | my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1); | ||
2594 : | my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0); | ||
2595 : | |||
2596 : | my $checkbox = $cgi->checkbox(-name => "checked", | ||
2597 : | -value => "to=$my_peg,from=$match_peg", | ||
2598 : | -label => ""); | ||
2599 : | my $good = 0; | ||
2600 : | my @list_of_ss = (); | ||
2601 : | my $ss_table_entry = "none"; | ||
2602 : | |||
2603 : | my (@list_of_returned_ss,$ss_name,$ss_role); | ||
2604 : | @list_of_returned_ss = $fig->subsystems_for_peg($match_peg); | ||
2605 : | if (@list_of_returned_ss > 0) | ||
2606 : | { | ||
2607 : | for my $ret_ss (@list_of_returned_ss) | ||
2608 : | { | ||
2609 : | ($ss_name,$ss_role)= @$ret_ss; | ||
2610 : | if ($ss_name !~/Unique/) | ||
2611 : | { | ||
2612 : | $good = 1; | ||
2613 : | } | ||
2614 : | } | ||
2615 : | } | ||
2616 : | |||
2617 : | if ($good) | ||
2618 : | { | ||
2619 : | my (@list_of_returned_ss,$ss_name,$ss_role); | ||
2620 : | @list_of_returned_ss = $fig->subsystems_for_peg($my_peg); | ||
2621 : | if (@list_of_returned_ss > 0) | ||
2622 : | { | ||
2623 : | for my $ret_ss (@list_of_returned_ss) | ||
2624 : | { | ||
2625 : | ($ss_name,$ss_role)= @$ret_ss; | ||
2626 : | if ($ss_name !~/Unique/) | ||
2627 : | { | ||
2628 : | push (@list_of_ss,$ss_name); | ||
2629 : | $ss_table_entry = join("<br>",@list_of_ss); | ||
2630 : | |||
2631 : | } | ||
2632 : | } | ||
2633 : | } | ||
2634 : | |||
2635 : | push(@$tbl, [$checkbox,$ss_table_entry, | ||
2636 : | $psc, | ||
2637 : | $my_peg_link, $my_len, $my_fn, | ||
2638 : | $match_peg_link, $match_len, $match_fn]); | ||
2639 : | } | ||
2640 : | |||
2641 : | |||
2642 : | } | ||
2643 : | |||
2644 : | push(@$html, &HTML::make_table($colhdr, $tbl, "")); | ||
2645 : | } | ||
2646 : | } | ||
2647 : | push(@$html, | ||
2648 : | $cgi->submit(-value => "Process assignments", | ||
2649 : | -name => "batch_assign"), | ||
2650 : | $cgi->end_form); | ||
2651 : | } | ||
2652 : | |||
2653 : | |||
2654 : | sub format_check_assignments { | ||
2655 : | my($fig,$cgi,$html,$subsystem) = @_; | ||
2656 : | my($org,$role); | ||
2657 : | |||
2658 : | my $user = $cgi->param('user'); | ||
2659 : | |||
2660 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
2661 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
2662 : | |||
2663 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
2664 : | my %activeC = map { $_ => 1 } @subsetC; | ||
2665 : | |||
2666 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
2667 : | |||
2668 : | push(@$html,$cgi->h1('Potentially Bad Assignments:')); | ||
2669 : | |||
2670 : | foreach $org (@subsetR) | ||
2671 : | { | ||
2672 : | next if (($_ = $cgi->param('just_genome_assignments')) && ($_ != $org)); | ||
2673 : | my @bad = (); | ||
2674 : | |||
2675 : | foreach $role (@subsetC) | ||
2676 : | { | ||
2677 : | next if (($_ = $cgi->param('just_role_assignments')) && ($_ != ($subsystem->get_role_index($role) + 1))); | ||
2678 : | push(@bad,&checked_assignments($cgi,$subsystem,$org,$role)); | ||
2679 : | } | ||
2680 : | |||
2681 : | if (@bad > 0) | ||
2682 : | { | ||
2683 : | my $genus_species = &ext_genus_species($fig,$org); | ||
2684 : | push(@$html,$cgi->h2("$org: $genus_species"), | ||
2685 : | $cgi->ul($cgi->li(\@bad))); | ||
2686 : | |||
2687 : | } | ||
2688 : | } | ||
2689 : | push(@$html,$cgi->hr); | ||
2690 : | } | ||
2691 : | |||
2692 : | sub checked_assignments { | ||
2693 : | my($cgi,$subsystem,$genome,$role) = @_; | ||
2694 : | my($peg,$line1,$line2,@out,$curr,$auto); | ||
2695 : | |||
2696 : | my(@bad) = (); | ||
2697 : | my @pegs = $subsystem->get_pegs_from_cell($genome,$role); | ||
2698 : | if (@pegs > 0) | ||
2699 : | { | ||
2700 : | my $tmp = "/tmp/tmp.pegs.$$"; | ||
2701 : | open(TMP,">$tmp") || die "could not open $tmp"; | ||
2702 : | foreach $peg (@pegs) | ||
2703 : | { | ||
2704 : | print TMP "$peg\n"; | ||
2705 : | } | ||
2706 : | close(TMP); | ||
2707 : | my $strict = $cgi->param('strict_check') ? "strict" : ""; | ||
2708 : | @out = `$FIG_Config::bin/check_peg_assignments $strict < $tmp 2> /dev/null`; | ||
2709 : | unlink($tmp); | ||
2710 : | |||
2711 : | while (($_ = shift @out) && ($_ =~ /^(fig\|\d+\.\d+\.peg\.\d+)/)) | ||
2712 : | { | ||
2713 : | $peg = $1; | ||
2714 : | if (($line1 = shift @out) && ($line1 =~ /^current:\s+(\S.*\S)/) && ($curr = $1) && | ||
2715 : | ($line2 = shift @out) && ($line2 =~ /^auto:\s+(\S.*\S)/) && ($auto = $1)) | ||
2716 : | { | ||
2717 : | if (! $fig->same_func($curr,$auto)) | ||
2718 : | { | ||
2719 : | my $link = &HTML::fid_link($cgi,$peg); | ||
2720 : | push(@bad,"$link<br>$line1<br>$line2<br><br>"); | ||
2721 : | } | ||
2722 : | } | ||
2723 : | } | ||
2724 : | } | ||
2725 : | return @bad; | ||
2726 : | } | ||
2727 : | |||
2728 : | sub format_dups { | ||
2729 : | my($fig,$cgi,$html,$subsystem) = @_; | ||
2730 : | |||
2731 : | my $user = $cgi->param('user'); | ||
2732 : | |||
2733 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
2734 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
2735 : | |||
2736 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
2737 : | my %activeC = map { $_ => 1 } @subsetC; | ||
2738 : | |||
2739 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
2740 : | |||
2741 : | push(@$html,$cgi->h1('To Check Duplicates:')); | ||
2742 : | |||
2743 : | my($org,$duplicates,$role,$genus_species); | ||
2744 : | foreach $org (@subsetR) | ||
2745 : | { | ||
2746 : | $duplicates = []; | ||
2747 : | foreach $role (@subsetC) | ||
2748 : | { | ||
2749 : | my(@pegs,$peg,$func); | ||
2750 : | if ((@pegs = $subsystem->get_pegs_from_cell($org,$role)) > 1) | ||
2751 : | { | ||
2752 : | push(@$duplicates,"$role<br>" . $cgi->ul($cgi->li([map { $peg = $_; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } @pegs]))); | ||
2753 : | } | ||
2754 : | } | ||
2755 : | |||
2756 : | if (@$duplicates > 0) | ||
2757 : | { | ||
2758 : | $genus_species = &ext_genus_species($fig,$org); | ||
2759 : | push(@$html,$cgi->h2("$org: $genus_species")); | ||
2760 : | push(@$html,$cgi->ul($cgi->li($duplicates))); | ||
2761 : | } | ||
2762 : | } | ||
2763 : | } | ||
2764 : | |||
2765 : | sub format_coupled { | ||
2766 : | my($fig,$cgi,$html,$subsystem,$type) = @_; | ||
2767 : | my($i,$j,@show,$user,$org,$link,$gs,$func,$peg,$peg1,$peg2,%in,%seen,%seen2); | ||
2768 : | my(@cluster,$sc,$x,$id2,@in,$sim,@coupled); | ||
2769 : | my($org,$role); | ||
2770 : | |||
2771 : | $user = $cgi->param('user'); | ||
2772 : | |||
2773 : | my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC ); | ||
2774 : | my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR ); | ||
2775 : | |||
2776 : | my @subsetC = $subsystem->get_subsetC_roles($active_subsetC); | ||
2777 : | my %activeC = map { $_ => 1 } @subsetC; | ||
2778 : | |||
2779 : | my @subsetR = $subsystem->get_subsetR($active_subsetR); | ||
2780 : | |||
2781 : | foreach $org (@subsetR) | ||
2782 : | { | ||
2783 : | foreach $role (@subsetC) | ||
2784 : | { | ||
2785 : | push(@in,$subsystem->get_pegs_from_cell($org,$role)); | ||
2786 : | } | ||
2787 : | } | ||
2788 : | |||
2789 : | %in = map { $_ => 1 } @in; | ||
2790 : | @show = (); | ||
2791 : | foreach $peg1 (@in) | ||
2792 : | { | ||
2793 : | if ($type eq "careful") | ||
2794 : | { | ||
2795 : | @coupled = $fig->coupling_and_evidence($peg1,5000,1.0e-10,0.2,1); | ||
2796 : | } | ||
2797 : | else | ||
2798 : | { | ||
2799 : | @coupled = $fig->fast_coupling($peg1,5000,1); | ||
2800 : | } | ||
2801 : | |||
2802 : | foreach $x (@coupled) | ||
2803 : | { | ||
2804 : | ($sc,$peg2) = @$x; | ||
2805 : | if ((! $in{$peg2}) && ((! $seen{$peg2}) || ($seen{$peg2} < $sc))) | ||
2806 : | { | ||
2807 : | $seen{$peg2} = $sc; | ||
2808 : | # print STDERR "$sc\t$peg1 -> $peg2\n"; | ||
2809 : | } | ||
2810 : | } | ||
2811 : | } | ||
2812 : | |||
2813 : | foreach $peg1 (sort { $seen{$b} <=> $seen{$a} } keys(%seen)) | ||
2814 : | { | ||
2815 : | if (! $seen2{$peg1}) | ||
2816 : | { | ||
2817 : | @cluster = ($peg1); | ||
2818 : | $seen2{$peg1} = 1; | ||
2819 : | for ($i=0; ($i < @cluster); $i++) | ||
2820 : | { | ||
2821 : | foreach $sim ($fig->sims($cluster[$i],1000,1.0e-10,"fig")) | ||
2822 : | { | ||
2823 : | $id2 = $sim->id2; | ||
2824 : | if ($seen{$id2} && (! $seen2{$id2})) | ||
2825 : | { | ||
2826 : | push(@cluster,$id2); | ||
2827 : | $seen2{$id2} = 1; | ||
2828 : | } | ||
2829 : | } | ||
2830 : | } | ||
2831 : | push(@show, [scalar @cluster, | ||
2832 : | $cgi->br . | ||
2833 : | $cgi->ul($cgi->li([map { $peg = $_; | ||
2834 : | $sc = $seen{$peg}; | ||
2835 : | $func = $fig->function_of($peg,$user); | ||
2836 : | $gs = $fig->genus_species($fig->genome_of($peg)); | ||
2837 : | $link = &HTML::fid_link($cgi,$peg); | ||
2838 : | "$sc: $link: $func \[$gs\]" } | ||
2839 : | sort { $seen{$b} <=> $seen{$a} } | ||
2840 : | @cluster])) | ||
2841 : | ]); | ||
2842 : | } | ||
2843 : | } | ||
2844 : | |||
2845 : | if (@show > 0) | ||
2846 : | { | ||
2847 : | @show = map { $_->[1] } sort { $b->[0] <=> $a->[0] } @show; | ||
2848 : | push(@$html,$cgi->h1('Coupled, but not in Spreadsheet:')); | ||
2849 : | push(@$html,$cgi->ul($cgi->li(\@show))); | ||
2850 : | } | ||
2851 : | } | ||
2852 : | |||
2853 : | sub ext_genus_species { | ||
2854 : | my($fig,$genome) = @_; | ||
2855 : | |||
2856 : | my $gs = $fig->genus_species($genome); | ||
2857 : | my $c = substr($fig->taxonomy_of($genome),0,1); | ||
2858 : | return "$gs [$c]"; | ||
2859 : | } | ||
2860 : | |||
2861 : | sub show_tree { | ||
2862 : | |||
2863 : | my($id,$gs); | ||
2864 : | my($tree,$ids) = $fig->build_tree_of_complete; | ||
2865 : | my $relabel = {}; | ||
2866 : | foreach $id (@$ids) | ||
2867 : | { | ||
2868 : | if ($gs = $fig->genus_species($id)) | ||
2869 : | { | ||
2870 : | $relabel->{$id} = "$gs ($id)"; | ||
2871 : | } | ||
2872 : | } | ||
2873 : | $_ = &display_tree($tree,$relabel); | ||
2874 : | print $cgi->pre($_),"\n"; | ||
2875 : | } | ||
2876 : | |||
2877 : | sub export_align_input | ||
2878 : | { | ||
2879 : | |||
2880 : | } | ||
2881 : | |||
2882 : | sub annotate_column { | ||
2883 : | # RAE: I added this function to allow you to reannotate a single column all at once | ||
2884 : | # this is because I wanted to update some of my annotations after looking at UniProt | ||
2885 : | # and couldn't see an easy way to do it. | ||
2886 : | my($fig,$cgi,$html,$col,$subsystem) = @_; | ||
2887 : | my $checked; | ||
2888 : | my $roles = [$subsystem->get_roles]; | ||
2889 : | my $role = &which_role_for_column($col,$roles); | ||
2890 : | my @checked = &seqs_to_align($role,$subsystem); | ||
2891 : | return undef unless (@checked); | ||
2892 : | |||
2893 : | # the following is read from fid_checked.cgi | ||
2894 : | push( @$html, "<table border=1>\n", | ||
2895 : | "<tr><td>Protein</td><td>Organism</td><td>Current Function</td><td>By Whom</td></tr>" | ||
2896 : | ); | ||
2897 : | |||
2898 : | foreach my $peg ( @checked ) { | ||
2899 : | my @funcs = $fig->function_of( $peg ); | ||
2900 : | if ( ! @funcs ) { @funcs = ( ["", ""] ) } | ||
2901 : | my $nfunc = @funcs; | ||
2902 : | my $org = $fig->org_of( $peg ); | ||
2903 : | push( @$html, "<tr>", | ||
2904 : | "<td rowspan=$nfunc>$peg</td>", | ||
2905 : | "<td rowspan=$nfunc>$org</td>" | ||
2906 : | ); | ||
2907 : | my ($who, $what); | ||
2908 : | push( @$html, join( "</tr>\n<tr>", map { ($who,$what) = @$_; "<td>$what</td><td>$who</td>" } @funcs ) ); | ||
2909 : | push( @$html, "</tr>\n" ); | ||
2910 : | } | ||
2911 : | push( @$html, "</table>\n" ); | ||
2912 : | |||
2913 : | push( @$html, $cgi->start_form(-action => "fid_checked.cgi", -target=>"_blank"), | ||
2914 : | $cgi->br, $cgi->br, | ||
2915 : | "<table>\n", | ||
2916 : | "<tr><td>New Function:</td>", | ||
2917 : | "<td>", $cgi->textfield(-name => "function", -size => 60), "</td></tr>", | ||
2918 : | "<tr><td colspan=2>", $cgi->hr, "</td></tr>", | ||
2919 : | "<tr><td>New Annotation:</td>", | ||
2920 : | "<td rowspan=2>", $cgi->textarea(-name => "annotation", -rows => 30, -cols => 60), "</td></tr>", | ||
2921 : | "<tr><td valign=top width=20%><br>", $cgi->submit('add annotation'), | ||
2922 : | "<p><b>Please note:</b> At the moment you need to make sure that the annotation in the table at the ", | ||
2923 : | "top of this page reflects the new annotation. This may not be updated automatically.</p>", | ||
2924 : | "</td></tr>", | ||
2925 : | "</table>", | ||
2926 : | $cgi->hidden(-name => 'user', -value => $user), | ||
2927 : | $cgi->hidden(-name => 'checked', -value => [@checked]), | ||
2928 : | $cgi->end_form | ||
2929 : | ); | ||
2930 : | } | ||
2931 : | |||
2932 : | |||
2933 : | |||
2934 : | sub align_column { | ||
2935 : | my($fig,$cgi,$html,$colN,$subsystem) = @_; | ||
2936 : | my(@pegs,$peg,$pseq,$role); | ||
2937 : | |||
2938 : | my $roles = [$subsystem->get_roles]; | ||
2939 : | my $name = $subsystem->get_name; | ||
2940 : | &check_index("$FIG_Config::data/Subsystems/$name/Alignments",$roles); | ||
2941 : | if (($role = &which_role_for_column($colN,$roles)) && | ||
2942 : | ((@pegs = &seqs_to_align($role,$subsystem)) > 1)) | ||
2943 : | { | ||
2944 : | my $tmpF = "/tmp/seqs.fasta.$$"; | ||
2945 : | open(TMP,">$tmpF") || die "could not open $tmpF"; | ||
2946 : | |||
2947 : | foreach $peg (@pegs) | ||
2948 : | { | ||
2949 : | if ($pseq = $fig->get_translation($peg)) | ||
2950 : | { | ||
2951 : | $pseq =~ s/[uU]/x/g; | ||
2952 : | print TMP ">$peg\n$pseq\n"; | ||
2953 : | } | ||
2954 : | } | ||
2955 : | close(TMP); | ||
2956 : | |||
2957 : | my $name = $subsystem->get_name; | ||
2958 : | my $dir = "$FIG_Config::data/Subsystems/$name/Alignments/$colN"; | ||
2959 : | |||
2960 : | if (-d $dir) | ||
2961 : | { | ||
2962 : | system "rm -rf \"$dir\""; | ||
2963 : | } | ||
2964 : | |||
2965 : | &FIG::run("$FIG_Config::bin/split_and_trim_sequences \"$dir/split_info\" < $tmpF"); | ||
2966 : | |||
2967 : | if (-s "$dir/split_info/set.sizes") | ||
2968 : | { | ||
2969 : | open(SZ,"<$dir/split_info/set.sizes") || die " could not open $dir/split_info/set.sizes"; | ||
2970 : | while (defined($_ = <SZ>)) | ||
2971 : | { | ||
2972 : | if (($_ =~ /^(\d+)\t(\d+)/) && ($2 > 3)) | ||
2973 : | { | ||
2974 : | my $n = $1; | ||
2975 : | &FIG::run("$FIG_Config::bin/make_phob_from_seqs \"$dir/$n\" < \"$dir/split_info\"/$n"); | ||
2976 : | } | ||
2977 : | } | ||
2978 : | close(SZ); | ||
2979 : | &update_index("$FIG_Config::data/Subsystems/$name/Alignments/index",$colN,$role); | ||
2980 : | } | ||
2981 : | else | ||
2982 : | { | ||
2983 : | system("rm -rf \"$dir\""); | ||
2984 : | } | ||
2985 : | } | ||
2986 : | } | ||
2987 : | |||
2988 : | sub align_subcolumn { | ||
2989 : | my($fig,$cgi,$html,$colN,$subcolN,$subsystem) = @_; | ||
2990 : | my($role,@pegs,$cutoff,$peg); | ||
2991 : | |||
2992 : | my $name = $subsystem->get_name; | ||
2993 : | my $dir = "$FIG_Config::data/Subsystems/$name/Alignments/$colN/$subcolN"; | ||
2994 : | my $roles = [$subsystem->get_roles]; | ||
2995 : | if (&check_index("$FIG_Config::data/Subsystems/$name/Alignments",$roles)) | ||
2996 : | { | ||
2997 : | my @pegs = map { $_ =~ /^(\S+)/; $1 } `cut -f2 $dir/ids`; | ||
2998 : | |||
2999 : | if ($cutoff = $cgi->param('include_homo')) | ||
3000 : | { | ||
3001 : | my $max = $cgi->param('max_homo'); | ||
3002 : | $max = $max ? $max : 100; | ||
3003 : | push(@pegs,&get_homologs($fig,\@pegs,$cutoff,$max)); | ||
3004 : | } | ||
3005 : | |||
3006 : | system "rm -rf \"$dir\""; | ||
3007 : | open(MAKE,"| make_phob_from_ids \"$dir\"") || die "could not make PHOB"; | ||
3008 : | foreach $peg (@pegs) | ||
3009 : | { | ||
3010 : | print MAKE "$peg\n"; | ||
3011 : | } | ||
3012 : | close(MAKE); | ||
3013 : | } | ||
3014 : | } | ||
3015 : | |||
3016 : | sub which_role_for_column { | ||
3017 : | my($col,$roles) = @_; | ||
3018 : | my($i); | ||
3019 : | |||
3020 : | if (($col =~ /^(\d+)/) && ($1 <= @$roles)) | ||
3021 : | { | ||
3022 : | return $roles->[$1-1]; | ||
3023 : | } | ||
3024 : | return undef; | ||
3025 : | } | ||
3026 : | |||
3027 : | sub seqs_to_align { | ||
3028 : | my($role,$subsystem) = @_; | ||
3029 : | my($genome); | ||
3030 : | |||
3031 : | my @seqs = (); | ||
3032 : | foreach $genome ($subsystem->get_genomes) | ||
3033 : | { | ||
3034 : | push(@seqs,$subsystem->get_pegs_from_cell($genome,$role)); | ||
3035 : | } | ||
3036 : | return @seqs; | ||
3037 : | } | ||
3038 : | |||
3039 : | sub get_homologs { | ||
3040 : | my($fig,$checked,$cutoff,$max) = @_; | ||
3041 : | my($peg,$sim,$id2); | ||
3042 : | |||
3043 : | my @homologs = (); | ||
3044 : | my %got = map { $_ => 1 } @$checked; | ||
3045 : | |||
3046 : | foreach $peg (@$checked) | ||
3047 : | { | ||
3048 : | foreach $sim ($fig->sims($peg,$max,$cutoff,"fig")) | ||
3049 : | { | ||
3050 : | $id2 = $sim->id2; | ||
3051 : | if ((! $got{$id2}) && ($id2 =~ /^fig\|(\d+\.\d+)/) && ($fig->is_complete($1))) | ||
3052 : | { | ||
3053 : | push(@homologs,[$sim->psc,$id2]); | ||
3054 : | $got{$id2} = 1; | ||
3055 : | } | ||
3056 : | } | ||
3057 : | } | ||
3058 : | @homologs = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @homologs; | ||
3059 : | if (@homologs > $max) { $#homologs = $max-1 } | ||
3060 : | |||
3061 : | return @homologs; | ||
3062 : | } | ||
3063 : | |||
3064 : | sub set_links { | ||
3065 : | my($cgi,$out) = @_; | ||
3066 : | |||
3067 : | my @with_links = (); | ||
3068 : | foreach $_ (@$out) | ||
3069 : | { | ||
3070 : | if ($_ =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/) | ||
3071 : | { | ||
3072 : | my($before,$peg,$after) = ($1,$2,$3); | ||
3073 : | push(@with_links, $before . &HTML::fid_link($cgi,$peg) . $after . "\n"); | ||
3074 : | } | ||
3075 : | else | ||
3076 : | { | ||
3077 : | push(@with_links,$_); | ||
3078 : | } | ||
3079 : | } | ||
3080 : | return @with_links; | ||
3081 : | } | ||
3082 : | |||
3083 : | sub reset_ssa { | ||
3084 : | my($fig,$cgi,$html) = @_; | ||
3085 : | my($ssa,@spreadsheets,$col_hdrs,$tab,$t,$readable,$url,$link,@tmp); | ||
3086 : | |||
3087 : | if (($ssa = $cgi->param('ssa_name')) && opendir(BACKUP,"$FIG_Config::data/Subsystems/$ssa/Backup")) | ||
3088 : | { | ||
3089 : | @spreadsheets = sort { $b <=> $a } | ||
3090 : | map { $_ =~ /^spreadsheet.(\d+)/; $1 } | ||
3091 : | grep { $_ =~ /^spreadsheet/ } | ||
3092 : | readdir(BACKUP); | ||
3093 : | closedir(BACKUP); | ||
3094 : | $col_hdrs = ["When","Number Genomes"]; | ||
3095 : | $tab = []; | ||
3096 : | foreach $t (@spreadsheets) | ||
3097 : | { | ||
3098 : | $readable = &FIG::epoch_to_readable($t); | ||
3099 : | $url = &FIG::cgi_url . "/subsys_hope.cgi?user=$user&ssa_name=" . uri_escape( $ssa ) . "&request=reset_to&ts=$t"; | ||
3100 : | $link = "<a href=$url>$readable</a>"; | ||
3101 : | open(TMP,"<$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t") | ||
3102 : | || die "could not open $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t"; | ||
3103 : | $/ = "//\n"; | ||
3104 : | $_ = <TMP>; | ||
3105 : | $_ = <TMP>; | ||
3106 : | $_ = <TMP>; | ||
3107 : | chomp; | ||
3108 : | $/ = "\n"; | ||
3109 : | |||
3110 : | @tmp = grep { $_ =~ /^\d+\.\d+/ } split(/\n/,$_); | ||
3111 : | push(@$tab,[$link,scalar @tmp]); | ||
3112 : | } | ||
3113 : | } | ||
3114 : | push(@$html,&HTML::make_table($col_hdrs,$tab,"Possible Points to Reset From")); | ||
3115 : | } | ||
3116 : | |||
3117 : | sub reset_ssa_to { | ||
3118 : | my($fig,$cgi,$html) = @_; | ||
3119 : | my($ts,$ssa); | ||
3120 : | |||
3121 : | if (($ssa = $cgi->param('ssa_name')) && | ||
3122 : | ($ts = $cgi->param('ts')) && | ||
3123 : | (-s "$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts")) | ||
3124 : | { | ||
3125 : | system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts $FIG_Config::data/Subsystems/$ssa/spreadsheet"; | ||
3126 : | chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet"); | ||
3127 : | if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts") | ||
3128 : | { | ||
3129 : | system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts $FIG_Config::data/Subsystems/$ssa/notes"; | ||
3130 : | chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes"); | ||
3131 : | } | ||
3132 : | |||
3133 : | if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/reactions.$ts") | ||
3134 : | { | ||
3135 : | system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/reactions.$ts $FIG_Config::data/Subsystems/$ssa/reactions"; | ||
3136 : | chmod(0777,"$FIG_Config::data/Subsystems/$ssa/reactions"); | ||
3137 : | } | ||
3138 : | |||
3139 : | my $subsystem = new Subsystem($ssa,$fig,0); | ||
3140 : | $subsystem->db_sync(0); | ||
3141 : | undef $subsystem; | ||
3142 : | } | ||
3143 : | } | ||
3144 : | |||
3145 : | sub make_exchangable { | ||
3146 : | my($fig,$cgi,$html) = @_; | ||
3147 : | my($ssa); | ||
3148 : | |||
3149 : | if (($ssa = $cgi->param('ssa_name')) && | ||
3150 : | (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet") && | ||
3151 : | open(TMP,">$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE")) | ||
3152 : | { | ||
3153 : | print TMP "1\n"; | ||
3154 : | close(TMP); | ||
3155 : | chmod(0777,"$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"); | ||
3156 : | } | ||
3157 : | } | ||
3158 : | |||
3159 : | sub make_unexchangable { | ||
3160 : | my($fig,$cgi,$html) = @_; | ||
3161 : | my($ssa); | ||
3162 : | |||
3163 : | if (($ssa = $cgi->param('ssa_name')) && | ||
3164 : | (-s "$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE")) | ||
3165 : | { | ||
3166 : | unlink("$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"); | ||
3167 : | } | ||
3168 : | } | ||
3169 : | |||
3170 : | sub which_role { | ||
3171 : | my($subsystem,$role_indicator) = @_; | ||
3172 : | my($n,$role,$abbr); | ||
3173 : | |||
3174 : | if (($role_indicator =~ /^\s*(\d+)\s*$/) && ($n = $1) && ($role = $subsystem->get_role($n-1))) | ||
3175 : | { | ||
3176 : | return $role; | ||
3177 : | } | ||
3178 : | elsif (($role_indicator =~ /^\s*(\S+)\s*$/) && ($abbr = $1) && ($role = $subsystem->get_role_from_abbr($abbr))) | ||
3179 : | { | ||
3180 : | return $role; | ||
3181 : | } | ||
3182 : | return ""; | ||
3183 : | } | ||
3184 : | |||
3185 : | sub external_id { | ||
3186 : | my($fig,$cgi,$peg) = @_; | ||
3187 : | my @tmp; | ||
3188 : | my @aliases = ($fig->feature_aliases($peg),map { $_->[0] } $fig->mapped_prot_ids($peg)); | ||
3189 : | if ((@tmp = grep { $_ =~ /^uni\|/ } @aliases) > 0) | ||
3190 : | { | ||
3191 : | @aliases = map { &HTML::uni_link($cgi,$_) } @tmp; | ||
3192 : | } | ||
3193 : | elsif ((@tmp = grep { $_ =~ /^sp\|/ } @aliases) > 0) | ||
3194 : | { | ||
3195 : | @aliases = map { &HTML::sp_link($cgi,$_) } @tmp; | ||
3196 : | } | ||
3197 : | elsif ((@tmp = grep { $_ =~ /^gi\|/ } @aliases) > 0) | ||
3198 : | { | ||
3199 : | @aliases = map { &HTML::gi_link($cgi,$_) } @tmp; | ||
3200 : | } | ||
3201 : | elsif ((@tmp = grep { $_ =~ /^kegg\|/ } @aliases) > 0) | ||
3202 : | { | ||
3203 : | @aliases = map { &HTML::kegg_link($cgi,$_) } @tmp; | ||
3204 : | } | ||
3205 : | else | ||
3206 : | { | ||
3207 : | return wantarray() ? (&HTML::fid_link($cgi,$peg)) : &HTML::fid_link($cgi,$peg); | ||
3208 : | } | ||
3209 : | |||
3210 : | if (wantarray()) | ||
3211 : | { | ||
3212 : | return @aliases; | ||
3213 : | } | ||
3214 : | else | ||
3215 : | { | ||
3216 : | return $aliases[0]; | ||
3217 : | } | ||
3218 : | } | ||
3219 : | |||
3220 : | sub cool_colors { | ||
3221 : | # just an array of "websafe" colors or whatever colors we want to use. Feel free to remove bad colors (hence the lines not being equal length!) | ||
3222 : | return ( | ||
3223 : | '#C0C0C0', '#FF40C0', '#FF8040', '#FF0080', '#FFC040', '#40C0FF', '#40FFC0', '#C08080', '#C0FF00', '#00FF80', '#00C040', | ||
3224 : | "#6B8E23", "#483D8B", "#2E8B57", "#008000", "#006400", "#800000", "#00FF00", "#7FFFD4", | ||
3225 : | "#87CEEB", "#A9A9A9", "#90EE90", "#D2B48C", "#8DBC8F", "#D2691E", "#87CEFA", "#E9967A", "#FFE4C4", "#FFB6C1", | ||
3226 : | "#E0FFFF", "#FFA07A", "#DB7093", "#9370DB", "#008B8B", "#FFDEAD", "#DA70D6", "#DCDCDC", "#FF00FF", "#6A5ACD", | ||
3227 : | "#00FA9A", "#228B22", "#1E90FF", "#FA8072", "#CD853F", "#DC143C", "#FF6347", "#98FB98", "#4682B4", | ||
3228 : | "#D3D3D3", "#7B68EE", "#2F4F4F", "#FF7F50", "#FF69B4", "#BC8F8F", "#A0522D", "#DEB887", "#00DED1", | ||
3229 : | "#6495ED", "#800080", "#FFD700", "#F5DEB3", "#66CDAA", "#FF4500", "#4B0082", "#CD5C5C", | ||
3230 : | "#EE82EE", "#7CFC00", "#FFFF00", "#191970", "#FFFFE0", "#DDA0DD", "#00BFFF", "#DAA520", "#008080", | ||
3231 : | "#00FF7F", "#9400D3", "#BA55D3", "#D8BFD8", "#8B4513", "#3CB371", "#00008B", "#5F9EA0", | ||
3232 : | "#4169E1", "#20B2AA", "#8A2BE2", "#ADFF2F", "#556B2F", | ||
3233 : | "#F0FFFF", "#B0E0E6", "#FF1493", "#B8860B", "#FF0000", "#F08080", "#7FFF00", "#8B0000", | ||
3234 : | "#40E0D0", "#0000CD", "#48D1CC", "#8B008B", "#696969", "#AFEEEE", "#FF8C00", "#EEE8AA", "#A52A2A", | ||
3235 : | "#FFE4B5", "#B0C4DE", "#FAF0E6", "#9ACD32", "#B22222", "#FAFAD2", "#808080", "#0000FF", | ||
3236 : | "#000080", "#32CD32", "#FFFACD", "#9932CC", "#FFA500", "#F0E68C", "#E6E6FA", "#F4A460", "#C71585", | ||
3237 : | "#BDB76B", "#00FFFF", "#FFDAB9", "#ADD8E6", "#778899", | ||
3238 : | ); | ||
3239 : | } | ||
3240 : | |||
3241 : | sub describe_colors { | ||
3242 : | my ($tvc)=@_; | ||
3243 : | my $tab = []; | ||
3244 : | my @colors=&cool_colors(); | ||
3245 : | my @labels=sort {$a cmp $b} keys %$tvc; | ||
3246 : | my $selfurl=$cgi->url(); | ||
3247 : | # recreate the url for the link | ||
3248 : | $selfurl .= "?user=" . $cgi->param('user') | ||
3249 : | . "&ssa_name=" . uri_escape( $cgi->param('ssa_name') ) | ||
3250 : | . "&request=" . $cgi->param('request') | ||
3251 : | . "&can_alter=" . $cgi->param('can_alter'); | ||
3252 : | |||
3253 : | my $row; | ||
3254 : | for (my $i=0; $i<= scalar @labels; $i++) { | ||
3255 : | next unless (defined $labels[$i]); | ||
3256 : | my $link='<a href="' . $selfurl . "&active_key=" . $cgi->param('color_by_ga') . "&active_value=" . $labels[$i] . '">' . $labels[$i] . "</a>\n"; | ||
3257 : | push @$row, [$link, "td style=\"background-color: $colors[$tvc->{$labels[$i]}]\""]; | ||
3258 : | unless (($i+1) % 10) { | ||
3259 : | push @$tab, $row; | ||
3260 : | undef $row; | ||
3261 : | } | ||
3262 : | } | ||
3263 : | push @$tab, $row; | ||
3264 : | return $tab; | ||
3265 : | } | ||
3266 : | |||
3267 : | sub existing_trees { | ||
3268 : | my($dir,$roles) = @_; | ||
3269 : | my(@rolesI,$roleI,@subrolesI,$subroleI); | ||
3270 : | |||
3271 : | &check_index("$dir/Alignments",$roles); | ||
3272 : | |||
3273 : | my @rolesA = (); | ||
3274 : | |||
3275 : | if (opendir(DIR,"$dir/Alignments")) | ||
3276 : | { | ||
3277 : | @rolesI = grep { $_ =~ /^(\d+)$/ } readdir(DIR); | ||
3278 : | closedir(DIR); | ||
3279 : | |||
3280 : | foreach $roleI (@rolesI) | ||
3281 : | { | ||
3282 : | if ((-d "$dir/Alignments/$roleI/split_info") && opendir(SUBDIR,"$dir/Alignments/$roleI")) | ||
3283 : | { | ||
3284 : | @subrolesI = grep { $_ =~ /^(\d+)$/ } readdir(SUBDIR); | ||
3285 : | closedir(SUBDIR); | ||
3286 : | |||
3287 : | foreach $subroleI (@subrolesI) | ||
3288 : | { | ||
3289 : | push(@rolesA,"$roleI.$subroleI: $roles->[$roleI-1]"); | ||
3290 : | } | ||
3291 : | } | ||
3292 : | } | ||
3293 : | } | ||
3294 : | |||
3295 : | my($x,$y); | ||
3296 : | return [sort { $a =~ /^(\d+\.\d+)/; $x = $1; | ||
3297 : | $b =~ /^(\d+\.\d+)/; $y = $1; | ||
3298 : | $x <=> $y | ||
3299 : | } @rolesA]; | ||
3300 : | } | ||
3301 : | |||
3302 : | sub check_index { | ||
3303 : | my($alignments,$roles) = @_; | ||
3304 : | |||
3305 : | if (-s "$alignments/index") | ||
3306 : | { | ||
3307 : | my $ok = 1; | ||
3308 : | foreach $_ (`cat \"$alignments/index\"`) | ||
3309 : | { | ||
3310 : | $ok = $ok && (($_ =~ /^(\d+)\t(\S.*\S)/) && ($roles->[$1 - 1] eq $2)); | ||
3311 : | } | ||
3312 : | if (! $ok) | ||
3313 : | { | ||
3314 : | system "rm -rf \"$alignments\""; | ||
3315 : | return 0; | ||
3316 : | } | ||
3317 : | return 1; | ||
3318 : | } | ||
3319 : | else | ||
3320 : | { | ||
3321 : | system "rm -rf \"$alignments\""; | ||
3322 : | } | ||
3323 : | return 0; | ||
3324 : | } | ||
3325 : | |||
3326 : | sub update_index { | ||
3327 : | my($file,$colN,$role) = @_; | ||
3328 : | |||
3329 : | my @lines = (); | ||
3330 : | if (-s $file) | ||
3331 : | { | ||
3332 : | @lines = grep { $_ !~ /^$colN\t/ } `cat $file`; | ||
3333 : | } | ||
3334 : | push(@lines,"$colN\t$role\n"); | ||
3335 : | open(TMP,">$file") || die "could not open $file"; | ||
3336 : | foreach $_ (@lines) | ||
3337 : | { | ||
3338 : | print TMP $_; | ||
3339 : | } | ||
3340 : | close(TMP); | ||
3341 : | } | ||
3342 : | |||
3343 : | sub show_sequences_in_column { | ||
3344 : | my($fig,$cgi,$html,$subsystem,$colN) = @_; | ||
3345 : | my(@pegs,$role); | ||
3346 : | |||
3347 : | my $roles = [$subsystem->get_roles]; | ||
3348 : | if (($role = &which_role_for_column($colN,$roles)) && | ||
3349 : | ((@pegs = &seqs_to_align($role,$subsystem)) > 0)) | ||
3350 : | { | ||
3351 : | push(@$html, "<pre>\n"); | ||
3352 : | foreach my $peg (@pegs) | ||
3353 : | { | ||
3354 : | my $seq; | ||
3355 : | if ($seq = $fig->get_translation($peg)) | ||
3356 : | { | ||
3357 : | push(@$html, ">$peg\n",&formatted_seq($seq)); | ||
3358 : | } | ||
3359 : | else | ||
3360 : | { | ||
3361 : | push(@$html, "could not find translation for $peg\n"); | ||
3362 : | } | ||
3363 : | } | ||
3364 : | push(@$html, "\n</pre>\n"); | ||
3365 : | } | ||
3366 : | else | ||
3367 : | { | ||
3368 : | push(@$html,$cgi->h1("Could not determine the role from $colN")); | ||
3369 : | } | ||
3370 : | } | ||
3371 : | |||
3372 : | sub formatted_seq { | ||
3373 : | my($seq) = @_; | ||
3374 : | my($i,$ln); | ||
3375 : | |||
3376 : | my @seqs = (); | ||
3377 : | my $n = length($seq); | ||
3378 : | for ($i=0; ($i < $n); $i += 60) { | ||
3379 : | if (($i + 60) <= $n) { | ||
3380 : | $ln = substr($seq,$i,60); | ||
3381 : | } else { | ||
3382 : | $ln = substr($seq,$i,($n-$i)); | ||
3383 : | } | ||
3384 : | push(@seqs,"$ln\n"); | ||
3385 : | } | ||
3386 : | return @seqs; | ||
3387 : | } | ||
3388 : | |||
3389 : | sub check_ssa { | ||
3390 : | my($fig,$cgi) = @_; | ||
3391 : | |||
3392 : | my $user = $cgi->param('user'); | ||
3393 : | my $ssa = $cgi->param('ssa_name'); | ||
3394 : | my $checked; | ||
3395 : | if ($user && $ssa) | ||
3396 : | { | ||
3397 : | $ENV{'REQUEST_METHOD'} = 'GET'; | ||
3398 : | $ENV{'QUERY_STRING'} = "user=$user&subsystem=$ssa&request=check_ssa"; | ||
3399 : | $checked = join("",`$FIG_Config::fig/CGI/check_subsys.cgi`); | ||
3400 : | if ($checked =~ /^.*?(<form .*form>)/s) | ||
3401 : | { | ||
3402 : | return $1; | ||
3403 : | } | ||
3404 : | } | ||
3405 : | return ""; | ||
3406 : | } | ||
3407 : |
MCS Webmaster | ViewVC Help |
Powered by ViewVC 1.0.3 |