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

Annotation of /FigWebServices/ssa2.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (view) (download)

1 : gdpusch 1.34 # -*- perl -*-
2 : olson 1.50 #
3 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     #
18 :    
19 : overbeek 1.26
20 : overbeek 1.1 use FIG;
21 : mkubal 1.43
22 : overbeek 1.1 my $fig = new FIG;
23 : mkubal 1.43
24 : overbeek 1.1 use HTML;
25 :     use strict;
26 :     use tree_utilities;
27 :    
28 :     use CGI;
29 :     my $cgi = new CGI;
30 :    
31 :     if (0)
32 :     {
33 :     my $VAR1;
34 :     eval(join("",`cat /tmp/ssa_parms`));
35 :     $cgi = $VAR1;
36 : overbeek 1.36 # print STDERR &Dumper($cgi);
37 : overbeek 1.1 }
38 :    
39 :     if (0)
40 :     {
41 :     print $cgi->header;
42 :     my @params = $cgi->param;
43 :     print "<pre>\n";
44 :     foreach $_ (@params)
45 :     {
46 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
47 :     }
48 :    
49 :     if (0)
50 :     {
51 :     if (open(TMP,">/tmp/ssa_parms"))
52 :     {
53 :     print TMP &Dumper($cgi);
54 :     close(TMP);
55 :     }
56 :     }
57 :     exit;
58 :     }
59 :    
60 :     my $request = $cgi->param("request");
61 :     if ($request && ($request eq "show_tree"))
62 :     {
63 :     print $cgi->header;
64 :     &show_tree;
65 :     exit;
66 :     }
67 :    
68 : redwards 1.40 # RAE: Added a title to the page
69 :     my $html = ["<title>The SEED: Subsytems Analysis</title>\n"];
70 : overbeek 1.1
71 :     my $user = $cgi->param('user');
72 :     if ((! $user) || ($user !~ /^master:\S+/))
73 :     {
74 :     push(@$html,$cgi->h1("Sorry, you need to specify a master user to modify subsystem annotations"));
75 :     }
76 : olson 1.10 elsif ($cgi->param("export_align_input"))
77 :     {
78 :     print $cgi->header;
79 :     print "exporting alignment input\n";
80 :     exit;
81 :     }
82 : olson 1.17 elsif ($cgi->param("extend_with_billogix"))
83 :     {
84 :     #
85 : mkubal 1.44 # Start bg task to extend the subsystem.
86 : olson 1.17 #
87 :    
88 :     my $ssa = $cgi->param('ssa_name');
89 :     my $user = $cgi->param('user');
90 :    
91 :     my $sub = $fig->get_subsystem($ssa);
92 : mkubal 1.44 my $mode = "regular";
93 : olson 1.17
94 :     TEST:
95 :     {
96 :     if ($sub)
97 :     {
98 :     #
99 :     # See if there's already an extend job running.
100 :     #
101 :    
102 :     my $curpid = $sub->get_current_extend_pid();
103 :     if ($curpid)
104 :     {
105 :     warn "Found current pid $curpid\n";
106 :     my $j = $fig->get_job($curpid);
107 :     warn "job is $j\n";
108 : olson 1.18 warn "running is ", $j->running(), "\n" if $j;
109 : olson 1.17 if ($j && $j->running())
110 :     {
111 :     push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
112 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
113 :     last;
114 :     }
115 :     }
116 :    
117 :     my $pid = $fig->run_in_background(sub {
118 : mkubal 1.46 $sub->extend_with_billogix($user);
119 : olson 1.17 });
120 :    
121 :     push(@$html,
122 :     "Subsystem extension started as background job number $pid <br>\n",
123 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
124 :    
125 :     $sub->set_current_extend_pid($pid);
126 :     }
127 :     else
128 :     {
129 :     push(@$html, "Subsystem '$ssa' could not be loaded");
130 :     }
131 :     }
132 :     &HTML::show_page($cgi, $html);
133 :    
134 :     exit;
135 :    
136 :     }
137 : mkubal 1.44
138 :    
139 :     elsif ($cgi->param("extend_NMPDR_with_billogix"))
140 :     {
141 :     #
142 :     # Start bg task to extend the subsystem.
143 :     #
144 :    
145 :     my $ssa = $cgi->param('ssa_name');
146 :     my $user = $cgi->param('user');
147 :    
148 :     my $sub = $fig->get_subsystem($ssa);
149 :     my $mode = "NMPDR";
150 :    
151 :     TEST:
152 :     {
153 :     if ($sub)
154 :     {
155 :     #
156 :     # See if there's already an extend job running.
157 :     #
158 :    
159 :     my $curpid = $sub->get_current_extend_pid();
160 :     if ($curpid)
161 :     {
162 :     warn "Found current pid $curpid\n";
163 :     my $j = $fig->get_job($curpid);
164 :     warn "job is $j\n";
165 :     warn "running is ", $j->running(), "\n" if $j;
166 :     if ($j && $j->running())
167 :     {
168 :     push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
169 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
170 :     last;
171 :     }
172 :     }
173 :    
174 :     my $pid = $fig->run_in_background(sub {
175 : mkubal 1.46 my $genomes = ['159288.1','159289.1','93061.1','196620.1','158878.1','158879.1','243277.1','223926.1','216895.1','196600.1','169963.1','265669.1','192222.1','160490.1','1314.1','198466.1','186103.1','193567.1','216600.1','171101.1','170187.1'];
176 :     $sub->extend_with_billogix($user,$genomes);
177 : mkubal 1.44 });
178 :    
179 :     push(@$html,
180 :     "Subsystem extension started as background job number $pid <br>\n",
181 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
182 :    
183 :     $sub->set_current_extend_pid($pid);
184 :     }
185 :     else
186 :     {
187 :     push(@$html, "Subsystem '$ssa' could not be loaded");
188 :     }
189 :     }
190 :     &HTML::show_page($cgi, $html);
191 :    
192 :     exit;
193 :    
194 :     }
195 :    
196 :    
197 :     elsif ($cgi->param("extend_CYANOS_with_billogix"))
198 :     {
199 :     #
200 :     # Start bg task to extend the subsystem.
201 :     #
202 : mkubal 1.46 warn "using cyanos version";
203 : mkubal 1.44 my $ssa = $cgi->param('ssa_name');
204 :     my $user = $cgi->param('user');
205 :    
206 :     my $sub = $fig->get_subsystem($ssa);
207 :     my $mode = "CYANOS";
208 :    
209 :     TEST:
210 :     {
211 :     if ($sub)
212 :     {
213 :     #
214 :     # See if there's already an extend job running.
215 :     #
216 :    
217 :     my $curpid = $sub->get_current_extend_pid();
218 :     if ($curpid)
219 :     {
220 :     warn "Found current pid $curpid\n";
221 :     my $j = $fig->get_job($curpid);
222 :     warn "job is $j\n";
223 :     warn "running is ", $j->running(), "\n" if $j;
224 :     if ($j && $j->running())
225 :     {
226 :     push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
227 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
228 :     last;
229 :     }
230 :     }
231 :    
232 :     my $pid = $fig->run_in_background(sub {
233 : mkubal 1.46 my $genomes = ['1140.1','84588.1','1148.1','167540.1','74547.1','167539.1','59919.1','240292.1','3702.1','251221.1','165597.1','63737.1','103690.1','39947.1','197221.1','203124.1'];
234 :     $sub->extend_with_billogix($user,$genomes);
235 : mkubal 1.44 });
236 :    
237 :     push(@$html,
238 :     "Subsystem extension started as background job number $pid <br>\n",
239 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
240 :    
241 :     $sub->set_current_extend_pid($pid);
242 :     }
243 :     else
244 :     {
245 :     push(@$html, "Subsystem '$ssa' could not be loaded");
246 :     }
247 :     }
248 :     &HTML::show_page($cgi, $html);
249 :    
250 :     exit;
251 :    
252 :     }
253 :    
254 :    
255 :    
256 : overbeek 1.1 else
257 :     {
258 :     $request = defined($request) ? $request : "";
259 :    
260 :     if ($request eq "reset")
261 :     {
262 :     &reset_ssa($fig,$cgi,$html);
263 :     }
264 :     elsif ($request eq "reset_to")
265 :     {
266 :     &reset_ssa_to($fig,$cgi,$html);
267 :     &show_ssa($fig,$cgi,$html);
268 :     }
269 :     elsif ($request eq "make_exchangable")
270 :     {
271 :     &make_exchangable($fig,$cgi,$html);
272 :     &show_initial($fig,$cgi,$html);
273 :     }
274 :     elsif ($request eq "make_unexchangable")
275 :     {
276 :     &make_unexchangable($fig,$cgi,$html);
277 :     &show_initial($fig,$cgi,$html);
278 :     }
279 :     elsif ($request eq "show_ssa")
280 :     {
281 :     &show_ssa($fig,$cgi,$html);
282 :     }
283 :     elsif ($request eq "show_ssa_noload")
284 :     {
285 :     &show_ssa_noload($fig,$cgi,$html);
286 :     }
287 : olson 1.8 #
288 :     # Note that this is a little different; I added another submit button
289 :     # to the delete_or_export_ssa form, so have to distinguish between them
290 :     # here based on $cgi->param('delete_export') - the original button,
291 :     # or $cgi->param('publish') - the new one.
292 :     #
293 :     elsif ($request eq "delete_or_export_ssa" and
294 :     defined($cgi->param('delete_export')))
295 : overbeek 1.1 {
296 :     my($ssa,$exported);
297 :     $exported = 0;
298 :     foreach $ssa ($cgi->param('export'))
299 :     {
300 :     if (! $exported)
301 :     {
302 :     print $cgi->header;
303 :     print "<pre>\n";
304 :     }
305 :     &export($fig,$cgi,$ssa);
306 :     $exported = 1;
307 :     }
308 :    
309 :     foreach $ssa ($cgi->param('export_assignments'))
310 :     {
311 :     &export_assignments($fig,$cgi,$ssa);
312 :     }
313 :    
314 :     foreach $ssa ($cgi->param('delete'))
315 :     {
316 : olson 1.28 my $sub = $fig->get_subsystem($ssa);
317 :     $sub->delete_indices();
318 :    
319 : olson 1.33 my $cmd = "rm -rf '$FIG_Config::data/Subsystems/$ssa'";
320 : olson 1.14 my $rc = system $cmd;
321 : overbeek 1.1 }
322 :    
323 :     if (! $exported)
324 :     {
325 :     &show_initial($fig,$cgi,$html);
326 :     }
327 :     else
328 :     {
329 :     print "</pre>\n";
330 :     exit;
331 :     }
332 :     }
333 : olson 1.8 elsif ($request eq "delete_or_export_ssa" and
334 :     defined($cgi->param('publish')))
335 :     {
336 :     my($ssa,$exported);
337 :     my($ch) = $fig->get_clearinghouse();
338 :    
339 :     print $cgi->header;
340 :    
341 :     if (!defined($ch))
342 :     {
343 :     print "cannot publish: clearinghouse not available\n";
344 :     exit;
345 :     }
346 :    
347 :     foreach $ssa ($cgi->param('publish_to_clearinghouse'))
348 :     {
349 :     print "<h2>Publishing $ssa to clearinghouse...</h2>\n";
350 :     $| = 1;
351 :     print "<pre>\n";
352 :     my $res = $fig->publish_subsystem_to_clearinghouse($ssa);
353 :     print "</pre>\n";
354 :     if ($res)
355 :     {
356 :     print "Published <i>$ssa </i> to clearinghouse<br>\n";
357 :     }
358 :     else
359 :     {
360 :     print "<b>Failed</b> to publish <i>$ssa</i> to clearinghouse<br>\n";
361 :     }
362 :     }
363 :     exit;
364 :     }
365 : overbeek 1.26 elsif (($request eq "new_ssa") && ($cgi->param('copy_from1')) && (! $cgi->param('cols_to_take1')))
366 :     {
367 :     my $user = $cgi->param('user');
368 :     my $name = $cgi->param('ssa_name');
369 :     my $copy_from1 = $cgi->param('copy_from1');
370 :     my $copy_from2 = $cgi->param('copy_from2');
371 :     my(@roles1,@roles2);
372 :    
373 :     push(@$html,$cgi->start_form(-action => "ssa2.cgi",
374 :     -method => 'post'),
375 :     $cgi->hidden(-name => 'copy_from1', -value => $copy_from1, -override => 1),
376 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
377 :     $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
378 :     $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1)
379 :     );
380 :    
381 :     @roles1 = $fig->subsystem_to_roles($copy_from1);
382 :     if (@roles1 > 0)
383 :     {
384 :     push(@$html,$cgi->h1("select columns to be taken from $copy_from1"),
385 :     $cgi->scrolling_list(-name => 'cols_to_take1',
386 :     -values => ['all',@roles1],
387 :     -size => 10,
388 :     -multiple => 1
389 :     ),
390 :     $cgi->hr
391 :     );
392 :     }
393 :    
394 :     if ($copy_from2)
395 :     {
396 :     @roles2 = $fig->subsystem_to_roles($copy_from2);
397 :     if (@roles2 > 0)
398 :     {
399 :     push(@$html,$cgi->hidden(-name => 'copy_from2', -value => $copy_from2, -override => 1));
400 :     push(@$html,$cgi->h1("select columns to be taken from $copy_from2"),
401 :     $cgi->scrolling_list(-name => 'cols_to_take2',
402 :     -values => ['all',@roles2],
403 :     -size => 10,
404 :     -multiple => 1
405 :     ),
406 :     $cgi->hr
407 :     );
408 :     }
409 :     }
410 :     push(@$html,$cgi->submit('build new subsystem'),
411 :     $cgi->end_form
412 :     );
413 :     }
414 : overbeek 1.1 elsif ($request eq "new_ssa")
415 :     {
416 :     &new_ssa($fig,$cgi,$html);
417 :     }
418 :     else
419 :     {
420 :     &show_initial($fig,$cgi,$html);
421 :     }
422 :     }
423 :    
424 :     &HTML::show_page($cgi,$html);
425 : golsen 1.48 exit;
426 : overbeek 1.1
427 : overbeek 1.26
428 : golsen 1.48 #=============================================================================
429 :     # Just subroutines below here
430 :     #=============================================================================
431 :    
432 : overbeek 1.1 sub show_initial {
433 :     my($fig,$cgi,$html) = @_;
434 :     my($set,$when,$comment);
435 :    
436 :     my $user = $cgi->param('user');
437 :     my @ssa = &existing_subsystem_annotations;
438 :    
439 :     if (@ssa > 0)
440 :     {
441 : overbeek 1.3 &format_ssa_table($cgi,$html,$user,\@ssa);
442 : overbeek 1.1 }
443 :    
444 :     my $target = "window$$";
445 : overbeek 1.24 push(@$html, $cgi->h1('To Start or Copy a Subsystem'),
446 : overbeek 1.2 $cgi->start_form(-action => "ssa2.cgi",
447 : overbeek 1.1 -target => $target,
448 :     -method => 'post'),
449 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
450 :     $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1),
451 : overbeek 1.24 "Name of New Subsystem: ",
452 : overbeek 1.1 $cgi->textfield(-name => "ssa_name", -size => 50),
453 : overbeek 1.5 $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1),
454 : overbeek 1.1 $cgi->br,
455 : overbeek 1.26
456 : overbeek 1.24 "Copy from (leave blank to start from scratch): ",
457 : overbeek 1.26 $cgi->textfield(-name => "copy_from1", -size => 50),
458 : overbeek 1.24 $cgi->br,
459 : overbeek 1.26
460 :     "Copy from (leave blank to start from scratch): ",
461 :     $cgi->textfield(-name => "copy_from2", -size => 50),
462 :     $cgi->br,
463 :    
464 : overbeek 1.24 $cgi->submit('start new subsystem'),
465 : overbeek 1.27 $cgi->end_form,
466 :     "<br>You can start a subsystem from scratch, in which case you should leave these two \"copy from\"
467 :     fields blank. If you wish to just copy a subsystem (in order to become the owner so that you can modify it),
468 :     just fill in one of the \"copy from\" fields with the name of the subsystem you wish to copy. If you wish to
469 :     extract a a subset of the columns to build a smaller spreadsheet (which could later be merged with another one),
470 :     fill in the name of the subsystem. You will be prompted for the columns that you wish to extract (choose <i>all</i> to
471 :     just copy all of the columns). Finally, if you wish to build a new spreadsheet by including columns from two existing
472 :     spreadsheets (including a complete merger), fill in the names of both the existing \"copy from\" subsystems"
473 : overbeek 1.1 );
474 :     }
475 :    
476 :     sub new_ssa {
477 :     my($fig,$cgi,$html) = @_;
478 :    
479 :     my $user = $cgi->param('user');
480 :     my $name = $cgi->param('ssa_name');
481 :    
482 :     if (! $user)
483 :     {
484 :     push(@$html,$cgi->h1('You need to specify a user before starting a new subsystem annotation'));
485 :     return;
486 :     }
487 :    
488 :     if (! $name)
489 :     {
490 :     push(@$html,$cgi->h1('You need to specify a subsystem name'));
491 :     return;
492 :     }
493 :    
494 :     my $ssa = $name;
495 : overbeek 1.26 $ssa =~ s/[ \/]/_/g;
496 : overbeek 1.1 &FIG::verify_dir("$FIG_Config::data/Subsystems");
497 :    
498 :     if (-d "$FIG_Config::data/Subsystems/$ssa")
499 :     {
500 :     push(@$html,$cgi->h1("You need to specify a new subsystem name; $ssa already is being used"));
501 :     return;
502 :     }
503 :     mkdir("$FIG_Config::data/Subsystems/$ssa",0777)
504 :     || die "could not make $FIG_Config::data/Subsystems/$ssa";
505 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa");
506 :    
507 :     open(LOG,">$FIG_Config::data/Subsystems/$ssa/curation.log")
508 :     || die "could not open $FIG_Config::data/Subsystems/$ssa/curation.log";
509 :     my $time = time;
510 :     print LOG "$time\t$user\tstarted\n";
511 :     close(LOG);
512 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa");
513 :    
514 : overbeek 1.26 my $copy_from1 = $cgi->param('copy_from1');
515 :     $copy_from1 =~ s/[ \/]/_/g;
516 :     my $copy_from2 = $cgi->param('copy_from2');
517 :     $copy_from2 =~ s/[ \/]/_/g;
518 :     my @cols_to_take1 = $cgi->param('cols_to_take1');
519 :     my @cols_to_take2 = $cgi->param('cols_to_take2');
520 :     my @subsys = ([],[],{}); # ([[Abbrev1,Role1],[Abbrev2,Role2],...],[Genome1,Genome2,...],PegHash)
521 :     # PegHash keys are of the form "$genome\t$role"
522 :     if ($copy_from1 && (@cols_to_take1 > 0))
523 :     {
524 :     &add_to_subsys($fig,$copy_from1,\@cols_to_take1,\@subsys);
525 :     }
526 :    
527 :     if ($copy_from2 && (@cols_to_take2 > 0))
528 : overbeek 1.24 {
529 : overbeek 1.26 &add_to_subsys($fig,$copy_from2,\@cols_to_take2,\@subsys);
530 :     }
531 :     if ((@{$subsys[0]} > 0) && (@{$subsys[1]} > 0))
532 :     {
533 :     # the following is a little ugly. In order to merge PEGs from two tables,
534 :     # subsys[2]->{$key} was made a hash keyed on peg IDs with values of 1. The
535 :     # write_subsystem_spreadsheet routine expects a list of peg IDs instead. The
536 :     # conversion is straightforward, but a bit opaque.
537 :     foreach $_ (keys(%{$subsys[2]}))
538 : overbeek 1.24 {
539 : overbeek 1.26 $subsys[2]->{$_} = [keys(%{$subsys[2]->{$_}})];
540 :     }
541 :     $fig->write_subsystem_spreadsheet($ssa,$subsys[0],$subsys[1],$subsys[2]);
542 :    
543 :     if ($copy_from1 && (-s "$FIG_Config::data/Subsystems/$copy_from1/notes"))
544 :     {
545 :     &FIG::run("cat \"$FIG_Config::data/Subsystems/$copy_from1/notes\" >> \"$FIG_Config::data/Subsystems/$ssa/notes\"");
546 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
547 :     }
548 :    
549 :     if ($copy_from2 && (-s "$FIG_Config::data/Subsystems/$copy_from2/notes"))
550 :     {
551 :     &FIG::run("cat \"$FIG_Config::data/Subsystems/$copy_from2/notes\" >> \"$FIG_Config::data/Subsystems/$ssa/notes\"");
552 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
553 : overbeek 1.24 }
554 :     }
555 : overbeek 1.26 $cgi->param(-name => "can_alter",
556 :     -value => 1);
557 : overbeek 1.1 &show_ssa($fig,$cgi,$html);
558 :     }
559 :    
560 : overbeek 1.26 sub add_to_subsys {
561 :     my($fig,$from,$cols,$subsys) = @_;
562 :     my($genomes,@genomes,$role,$genome,$peg);
563 :     my($roles,%to_add,@to_add);
564 :    
565 :     (undef,undef,undef,$roles) = $fig->subsystem_info($from);
566 :     my $all = grep { $_ eq "all" } @$cols;
567 :    
568 :     if (! $all)
569 :     {
570 :     %to_add = map { $_ => 1 } @$cols;
571 :     @to_add = grep { $to_add{$_->[1]} } @$roles; # list of [Abbrev,Role] now
572 :     }
573 :     else
574 :     {
575 :     @to_add = @$roles;
576 :     }
577 :     &add_cols($subsys,\@to_add);
578 :     $genomes = $fig->subsystem_genomes($from);
579 :     @genomes = map { $_->[0] } @$genomes;
580 :     &add_genomes($subsys,\@genomes);
581 :    
582 :     foreach $role (map { $_->[1] } @to_add)
583 :     {
584 :     foreach $genome (@genomes)
585 :     {
586 :     foreach $peg ($fig->pegs_in_subsystem_cell($from,$genome,$role))
587 :     {
588 :     $subsys->[2]->{"$genome\t$role"}->{$peg} = 1;
589 :     }
590 :     }
591 :     }
592 :     }
593 :    
594 :     sub add_cols {
595 :     my($subsys,$roles) = @_;
596 :     my($genome,$i,$role);
597 :    
598 :     foreach $role (@$roles)
599 :     {
600 :     for ($i=0; ($i < @{$subsys->[0]}) && ($role->[1] ne $subsys->[0]->[$i]->[1]); $i++) {}
601 :     if ($i == @{$subsys->[0]})
602 :     {
603 :     for ($i=0; ($i < @{$subsys->[0]}) && ($subsys->[0]->[$i]->[0] ne $role->[0]); $i++) {}
604 :     if ($i < @{$subsys->[0]})
605 :     {
606 :     $role->[0] .= "*"; # needed to disambiguate abbreviations
607 :     }
608 :     push(@{$subsys->[0]},$role);
609 :     }
610 :     }
611 :     }
612 :    
613 :     sub add_genomes {
614 :     my($subsys,$genomes) = @_;
615 :     my($genome,$i);
616 :    
617 :     foreach $genome (@$genomes)
618 :     {
619 :     for ($i=0; ($i < @{$subsys->[1]}) && ($genome ne $subsys->[1]->[$i]); $i++) {}
620 :     if ($i == @{$subsys->[1]})
621 :     {
622 :     push(@{$subsys->[1]},$genome);
623 :     }
624 :     }
625 :     }
626 :    
627 : overbeek 1.1 sub show_ssa {
628 :     my($fig,$cgi,$html) = @_;
629 :    
630 :     my $user = $cgi->param('user');
631 :     my $ssa = $cgi->param('ssa_name');
632 :    
633 :     if (! $user)
634 :     {
635 :     push(@$html,$cgi->h1('You need to specify a user to work on a subsystem annotation'));
636 :     return;
637 :     }
638 :    
639 :     if (! $ssa)
640 :     {
641 :     push(@$html,$cgi->h1('You need to specify a subsystem'));
642 :     return;
643 :     }
644 :    
645 :     my $name = $ssa;
646 :     $name =~ s/_/ /g;
647 : overbeek 1.26 $ssa =~ s/[ \/]/_/g;
648 : overbeek 1.1
649 :     if (open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
650 :     {
651 :     $/ = "//\n";
652 :     my($i,$role,%pos,$subset,$adj_subset,$genome,$row,$abbrev);
653 :     if (defined($_ = <SSA>) && $_)
654 :     {
655 :     $_ =~ s/\n?\/\/\n//s;
656 :     $i = 1;
657 :     foreach $role (split(/\n/,$_))
658 :     {
659 :     if ($role =~ /^(.*)\t(.*)$/)
660 :     {
661 :     $role = $2;
662 :     $abbrev = $1;
663 :     }
664 :     else
665 :     {
666 :     $abbrev = "";
667 :     }
668 :     $cgi->param(-name => "posR$i", -value => $i);
669 :     $cgi->param(-name => "role$i", -value => $role);
670 :     $cgi->param(-name => "abbrev$i", -value => $abbrev);
671 :     $pos{$role} = $i;
672 :     $i++;
673 :     }
674 : overbeek 1.3
675 : overbeek 1.1 if (defined($_ = <SSA>) && $_)
676 :     {
677 :     $_ =~ s/\n?\/\/\n//s;
678 :     my($subsetsC,$subsetsR) = split(/\n\n/,$_);
679 :     $i = 1;
680 :     my @subsetsC = split(/\n/,$subsetsC);
681 :     my $active_subsetC = (@subsetsC > 0) ? pop @subsetsC : "All";
682 :     $cgi->param(-name => 'active_subsetC', -value => $active_subsetC);
683 :     foreach $subset (@subsetsC)
684 :     {
685 :     my($nameCS,@subset_members) = split(/\s+/,$subset);
686 :     $cgi->param(-name => "nameCS$i", -value => $nameCS);
687 :     $adj_subset = join(" ",map { $pos{$_} ? $pos{$_} : $_ } @subset_members);
688 :     $cgi->param(-name => "subsetC$i", -value => $adj_subset);
689 :     $i++;
690 :     }
691 :    
692 :     my $active_subsetR = ($subsetsR && ($subsetsR =~ /^(\S[^\n]+\S)/)) ? $1 : "All";
693 :     $cgi->param(-name => 'active_subsetR', -value => $active_subsetR);
694 :     $/ = "\n";
695 :     $i = 1;
696 : overbeek 1.9 my(%seen);
697 : overbeek 1.1 while (defined($_ = <SSA>))
698 :     {
699 :     chop;
700 :     my($entry,$checked);
701 :     my @row = split(/\t/,$_);
702 : overbeek 1.35 next if (($seen{$row[0]}) || ($row[0] =~ /^99999/));
703 : overbeek 1.9 $seen{$row[0]} = 1;
704 :    
705 : overbeek 1.1 if (@row > 0)
706 :     {
707 :     $genome = shift @row;
708 :     $cgi->param(-name => "genome$i", -value => $genome);
709 :     $checked = shift @row;
710 :     $cgi->param(-name => "vcode$i", -value => $checked);
711 :     }
712 :     else
713 :     {
714 :     $cgi->param(-name => "vcode$i", -value => 0);
715 :     }
716 :    
717 :     my $j = 1;
718 :     foreach $entry (@row)
719 :     {
720 :     $cgi->param(-name => "row$i.$j", -value => $entry);
721 :     $j++;
722 :     }
723 :     $i++;
724 :     }
725 :     }
726 :     close(SSA);
727 :     }
728 : overbeek 1.3
729 : overbeek 1.1 if (-s "$FIG_Config::data/Subsystems/$ssa/notes")
730 :     {
731 : olson 1.22 my $notes = &FIG::file_read("$FIG_Config::data/Subsystems/$ssa/notes");
732 : overbeek 1.31 if (! $notes)
733 :     {
734 :     confess "BAD notes";
735 :     }
736 : overbeek 1.1 $cgi->param(-name => 'notes', -value => $notes);
737 :     }
738 :     }
739 :     else
740 :     {
741 :     &format_empty_ssa("$FIG_Config::data/Subsystems/$ssa/spreadsheet");
742 :     }
743 :     &show_ssa_noload($fig,$cgi,$html);
744 :     }
745 :    
746 :     sub format_empty_ssa {
747 :     my($file) = @_;
748 :    
749 :     open(SSA,">$file") || die "aborted";
750 :     print SSA "//\nAll\n\n";
751 :     &print_default_genome_set(\*SSA);
752 :     print SSA "//\n";
753 :     close(SSA);
754 :     }
755 :    
756 :     sub print_default_genome_set {
757 :     my($fh) = @_;
758 :    
759 :     print $fh &default_genome_set, "\n";
760 :     }
761 :    
762 :     sub default_genome_set {
763 :     return "All";
764 :     }
765 :    
766 :     sub show_ssa_noload {
767 :     my($fig,$cgi,$html) = @_;
768 :     my($col);
769 :    
770 :     my $user = $cgi->param('user');
771 :     my $ssa = $cgi->param('ssa_name');
772 : overbeek 1.5 my $can_alter = $cgi->param('can_alter');
773 : overbeek 1.1 if (! $user)
774 :     {
775 :     push(@$html,$cgi->h1('You need to specify a user to work on a subsystem annotation'));
776 :     return;
777 :     }
778 :    
779 :     if (! $ssa)
780 :     {
781 :     push(@$html,$cgi->h1('You need to specify a subsystem'));
782 :     return;
783 :     }
784 :    
785 :     my $name = $ssa;
786 : mkubal 1.43
787 :     my $sub_sys = $fig->get_subsystem($name);
788 :     my @genomes_in_sub_sys = $sub_sys->get_genomes();
789 :     my $n = @genomes_in_sub_sys;
790 :    
791 : overbeek 1.1 $name =~ s/_/ /g;
792 : overbeek 1.26 $ssa =~ s/[ \/]/_/g;
793 : overbeek 1.1
794 :     push(@$html, $cgi->h1("Subsystem: $name"),
795 : mkubal 1.43 $cgi->h1("# of Genomes present: $n"),
796 : overbeek 1.2 $cgi->start_form(-action => "ssa2.cgi",
797 : overbeek 1.1 -method => 'post'),
798 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
799 :     $cgi->hidden(-name => 'request', -value => 'show_ssa_noload', -override => 1),
800 : overbeek 1.5 $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
801 : overbeek 1.1 $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
802 :     $cgi->br,
803 :     );
804 :    
805 :     my($roles,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR,$genomes,$rows) = &write_spreadsheet_from_input_parameters($fig,$cgi,$html,$ssa,$user);
806 : overbeek 1.36
807 : overbeek 1.1 &format_roles($fig,$cgi,$html,$roles,$genomes,$rows);
808 :     &format_subsets($fig,$cgi,$html,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
809 :     &format_rows($fig,$cgi,$html,$roles,$genomes,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
810 :    
811 : overbeek 1.5 if ($can_alter)
812 : overbeek 1.3 {
813 :     &format_extend_with($fig,$cgi,$html,$genomes,$roles);
814 :     push(@$html,$cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill'),$cgi->br);
815 :     push(@$html,$cgi->br);
816 :     push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
817 :     }
818 : mkubal 1.44
819 :     if ($can_alter)
820 :     {
821 : mkubal 1.45 #my $genome_list = ['1140.1','84588.1','1148.1','167540.1','74547.1','167539.1','59919.1','240292.1','3702.1','251221.1','165597.1','63737.1','103690.1','39947.1','197221.1','203124.1'];
822 :     &format_extend_with_CYANOS($fig,$cgi,$html,$genomes,$roles);
823 : mkubal 1.44 push(@$html,$cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill'),$cgi->br);
824 :     push(@$html,$cgi->br);
825 :     push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
826 :     }
827 :    
828 :     if ($can_alter)
829 :     {
830 :    
831 : mkubal 1.45 #my $genome_list = ['159288.1','159289.1','93061.1','196620.1','158878.1','158879.1','243277.1','223926.1','216895.1','196600.1','169963.1','265669.1','192222.1','160490.1','1314.1','198466.1','186103.1','193567.1','216600.1','171101.1','170187.1'];
832 :     &format_extend_with_NMPDR($fig,$cgi,$html,$genomes,$roles);
833 : mkubal 1.44 push(@$html,$cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill'),$cgi->br);
834 :     push(@$html,$cgi->br);
835 :     push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
836 :     }
837 :    
838 : overbeek 1.3 else
839 :     {
840 :     push(@$html,$cgi->br);
841 :     push(@$html,$cgi->submit('show spreadsheet'),$cgi->br);
842 : olson 1.11
843 : overbeek 1.3 }
844 : olson 1.17
845 : olson 1.11 push(@$html, $cgi->a({href => "ss_export.cgi?user=$user&ssa_name=$ssa"},
846 :     "Export subsystem data"),
847 :     $cgi->br);
848 : redwards 1.41
849 :     my $expand = $cgi->param('ignore_alt');
850 :     push(@$html,$cgi->checkbox(-name => 'ignore_alt', -value => 1, -checked => $expand, -override => 1,-label => 'ignore alternatives'),$cgi->br);
851 : overbeek 1.1 push(@$html,$cgi->checkbox(-name => 'show_clusters', -value => 1, -checked => 0, -override => 1,-label => 'show clusters'),$cgi->br);
852 :     push(@$html,$cgi->checkbox(-name => 'show_missing', -value => 1, -checked => 0, -override => 1,-label => 'show missing'),$cgi->br);
853 : overbeek 1.24 push(@$html,$cgi->checkbox(-name => 'show_missing_including_matches', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches'),
854 :     "&nbsp; &nbsp; [To restrict to a single genome: ",
855 :     $cgi->textfield(-name => "just_genome", -size => 15),"]",
856 :     $cgi->br
857 :     );
858 : overbeek 1.6 push(@$html,$cgi->checkbox(-name => 'refill', -value => 1, -checked => 0, -override => 1,-label => 'refill spreadsheet from scratch'),$cgi->br);
859 : overbeek 1.1 push(@$html,$cgi->checkbox(-name => 'show_dups', -value => 1, -checked => 0, -override => 1,-label => 'show duplicates'),$cgi->br);
860 :     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);
861 :     push(@$html,$cgi->checkbox(-name => 'show_excluded', -value => 1, -checked => 0, -override => 1,-label => 'show PEGs that have roles, but not in spreadsheet'),$cgi->br);
862 :     push(@$html,$cgi->checkbox(-name => 'add_solid', -value => 1, -checked => 0, -override => 1,-label => 'Add Genomes with Solid Hits'),$cgi->br);
863 :     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);
864 : overbeek 1.3 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);
865 : overbeek 1.1 push(@$html,$cgi->br,"Align column: ",
866 :     $cgi->textfield(-name => "col_to_align", -size => 7),
867 : olson 1.10 $cgi->checkbox(-name => "show_align_input", -checked => 0,
868 :     -label => "show input to alignment tool"),
869 : overbeek 1.1 $cgi->br,"Include homologs that pass the following threshhold: ",
870 :     $cgi->textfield(-name => "include_homo", -size => 10)," (leave blank to see just column)",
871 :     " Max homologous seqs: ",$cgi->textfield(-name => "max_homo", -value => 100, -size => 6),
872 : olson 1.17 );
873 :    
874 :     if ($can_alter)
875 :     {
876 :     push(@$html,
877 :     $cgi->p,
878 :     $cgi->submit(-value => "Start automated subsystem extension",
879 :     -name => "extend_with_billogix"),
880 :     $cgi->br);
881 :     }
882 :     push(@$html, $cgi->hr);
883 : mkubal 1.44
884 :     if ($can_alter)
885 :     {
886 :     push(@$html,
887 :     $cgi->p,
888 :     $cgi->submit(-value => "Start automated subsystem extension for Phototrophs",
889 :     -name => "extend_CYANOS_with_billogix"),
890 :     $cgi->br);
891 :     }
892 :     push(@$html, $cgi->hr);
893 :    
894 :    
895 :     if ($can_alter)
896 :     {
897 :     push(@$html,
898 :     $cgi->p,
899 :     $cgi->submit(-value => "Start automated subsystem extension for NMPDR",
900 :     -name => "extend_NMPDR_with_billogix"),
901 :     $cgi->br);
902 :     }
903 :     push(@$html, $cgi->hr);
904 :    
905 : overbeek 1.1
906 :     if ($cgi->param('show_missing'))
907 :     {
908 :     &format_missing($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
909 :     }
910 :    
911 : olson 1.15 if ($cgi->param('show_missing_including_matches'))
912 :     {
913 : olson 1.16 #
914 :     # Need to end the form that was started above; hope that doesn't cause problems.
915 :     #
916 :     push(@$html, $cgi->end_form);
917 :    
918 : olson 1.15 &format_missing_including_matches($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
919 :     }
920 :    
921 : overbeek 1.1 if ($cgi->param('show_dups'))
922 :     {
923 :     &format_dups($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
924 :     }
925 :    
926 :     if ($cgi->param('show_excluded'))
927 :     {
928 :     &format_excluded($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
929 :     }
930 :    
931 :     if ($cgi->param('show_coupled'))
932 :     {
933 :     &format_coupled($fig,$cgi,$html,$genomes,$roles,$rows,"careful",$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
934 :     }
935 :     elsif ($cgi->param('show_coupled_fast'))
936 :     {
937 :     &format_coupled($fig,$cgi,$html,$genomes,$roles,$rows,"fast",$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
938 :     }
939 :    
940 :     if ($col = $cgi->param('col_to_align'))
941 :     {
942 :     &align_column($fig,$cgi,$html,$col,$roles,$genomes,$rows,$subsetsR,$active_subsetR);
943 :     }
944 :    
945 : overbeek 1.26 my $notes = $cgi->param('notes');;
946 :     if ((-s "$FIG_Config::data/Subsystems/$ssa/notes") && (! $notes))
947 : overbeek 1.1 {
948 : olson 1.22 $notes = &FIG::file_read("$FIG_Config::data/Subsystems/$ssa/notes");
949 : overbeek 1.31 if (! $notes)
950 :     {
951 :     confess "BAD notes";
952 :     }
953 : overbeek 1.1 }
954 :     push(@$html,$cgi->hr,"NOTES:\n",$cgi->br,$cgi->textarea(-name => 'notes', -rows => 40, -cols => 100, -value => $notes));
955 :     }
956 :    
957 : golsen 1.48
958 :     #-----------------------------------------------------------------------------
959 :     # Selection list of complete genomes not in spreadsheet:
960 :     #-----------------------------------------------------------------------------
961 :    
962 : overbeek 1.1 sub format_extend_with {
963 : golsen 1.48 my ( $fig, $cgi, $html, $genomes, $roles ) = @_;
964 :    
965 : golsen 1.49 my %genomes = map { $_ => 1 } @$genomes;
966 :    
967 :     my @orgs = map { [ $_ , &ext_genus_species( $fig, $_ ), scalar $fig->all_contigs( $_ ) ] }
968 :     grep { ! $genomes{ $_ } }
969 :     $fig->genomes( "complete", undef );
970 :    
971 :     my $pick_order = $cgi->param('pick_order') || 'Alphabetic';
972 :     if ( $pick_order eq "Phylogenetic" )
973 :     {
974 :     @orgs = sort { $a->[3] cmp $b->[3] }
975 :     map { push @$_, $fig->taxonomy_of( $_->[0] ); $_ }
976 :     @orgs;
977 :     }
978 :     elsif ( $pick_order eq "Genome ID" )
979 :     {
980 :     @orgs = sort { $a->[3]->[0] <=> $b->[3]->[0] || $a->[3]->[1] <=> $b->[3]->[1] }
981 :     map { push @$_, [ split /\./ ]; $_ }
982 :     @orgs;
983 :     }
984 :     else
985 :     {
986 :     $pick_order = 'Alphabetic';
987 :     @orgs = sort { $a->[1] cmp $b->[1] } @orgs;
988 :     }
989 : golsen 1.48
990 : golsen 1.49 @orgs = map { "$_->[1] ($_->[0]) [$_->[2] contigs]" } @orgs;
991 : golsen 1.48
992 : golsen 1.49 my @order_opt = $cgi->radio_group( -name => 'pick_order',
993 :     -values => [ 'Alphabetic', 'Phylogenetic', 'Genome ID' ],
994 :     -default => $pick_order,
995 :     -override => 1
996 :     );
997 :    
998 :     push( @$html, $cgi->h1('Pick Organisms to Extend with'), "\n",
999 :     "<TABLE>\n",
1000 :     " <TR>\n",
1001 :     " <TD>",
1002 :     $cgi->scrolling_list( -name => 'korgs',
1003 :     -values => [ @orgs ],
1004 :     -size => 10,
1005 :     -multiple => 1
1006 :     ),
1007 :     " </TD>\n",
1008 :     " <TD>", join( "<BR>\n", "Order of selection list:", @order_opt ),
1009 :     " </TD>\n",
1010 :     " </TR>\n",
1011 :     "</TABLE>\n",
1012 :     $cgi->hr
1013 :     );
1014 : overbeek 1.1 }
1015 :    
1016 : golsen 1.49
1017 : mkubal 1.44 sub format_extend_with_CYANOS {
1018 :     my($fig,$cgi,$html,$genomes,$roles) = @_;
1019 : mkubal 1.46 my($org,$gs, $gc);
1020 : mkubal 1.45 my @genome_list = ('1140.1','84588.1','1148.1','167540.1','74547.1','167539.1','59919.1','240292.1','3702.1','251221.1','165597.1','63737.1','103690.1','39947.1','197221.1','203124.1');
1021 : mkubal 1.44 #my %genomes = map { $_ => 1 } @genome_list;
1022 :     my %genomes = map { $_ => 1 } @$genomes;
1023 : mkubal 1.45 my @orgs = sort map { $org = $_; $gs = &ext_genus_species($fig,$org); $gc=scalar $fig->all_contigs($org); "$gs ($org) [$gc contigs]" } grep { ! $genomes{$_} }
1024 :     @genome_list;
1025 : mkubal 1.44
1026 :     push(@$html,
1027 :     $cgi->h1('Pick Phototrophic Genomes to Extend with'),
1028 :     $cgi->scrolling_list(-name => 'korgs',
1029 :     -values => [@orgs],
1030 :     -size => 10,
1031 :     -multiple => 1
1032 :     ),
1033 :     $cgi->hr
1034 :     );
1035 :     }
1036 :    
1037 :     sub format_extend_with_NMPDR {
1038 :     my($fig,$cgi,$html,$genomes,$roles) = @_;
1039 :     my($org,$gs, $gc);
1040 : mkubal 1.45 my @genome_list = ('159288.1','159289.1','93061.1','196620.1','158878.1','158879.1','243277.1','223926.1','216895.1','196600.1','169963.1','265669.1','192222.1','160490.1','1314.1','198466.1','186103.1','193567.1','216600.1','171101.1','170187.1');
1041 : mkubal 1.44 #my %genomes = map { $_ => 1 } @genome_list;
1042 :     my %genomes = map { $_ => 1 } @$genomes;
1043 :    
1044 : mkubal 1.45 my @orgs = sort map { $org = $_; $gs = &ext_genus_species($fig,$org); $gc=scalar $fig->all_contigs($org); "$gs ($org) [$gc contigs]" } grep { ! $genomes{$_} } @genome_list;
1045 :     #my @orgs = sort map { $org = $_; $gs = &ext_genus_species($fig,$org); $gc=scalar $fig->all_contigs($org); "$gs ($org) [$gc contigs]" } @$genomes;
1046 : mkubal 1.44
1047 :     push(@$html,
1048 :     $cgi->h1('Pick NMPDR Genomes to Extend with'),
1049 :     $cgi->scrolling_list(-name => 'korgs',
1050 :     -values => [@orgs],
1051 :     -size => 10,
1052 :     -multiple => 1
1053 :     ),
1054 :     $cgi->hr
1055 :     );
1056 :    
1057 :    
1058 :     }
1059 :    
1060 : overbeek 1.1 sub format_rows {
1061 :     my($fig,$cgi,$html,$roles,$genomes,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
1062 :    
1063 :     my($i);
1064 :     my $subsetC = $subsetsC->{$active_subsetC};
1065 :     my $subsetR = $subsetsR->{$active_subsetR};
1066 : overbeek 1.36
1067 : overbeek 1.1 if (@$rows > 0)
1068 :     {
1069 :     my $col_hdrs = ["Genome ID","Organism","Variant Code"];
1070 :     for ($i=1; ($i < @$roles); $i++)
1071 :     {
1072 :     if ($roles->[$i])
1073 :     {
1074 :     if ($subsetC->{$i})
1075 :     {
1076 :     if ($roles->[$i] =~ /^(.*\S.*)\t(.*)$/)
1077 :     {
1078 :     push(@$col_hdrs,$1);
1079 :     }
1080 :     else
1081 :     {
1082 :     push(@$col_hdrs,$i);
1083 :     }
1084 :     }
1085 :     }
1086 :     }
1087 : overbeek 1.36 my $tab = &format_existing_rows($fig,$cgi,$html,$genomes,$rows,$roles,$subsetC,$subsetR,$col_hdrs);
1088 :     ($col_hdrs,$tab) = &format_alternatives($cgi,$subsetC,$subsetsC,$col_hdrs,$tab);
1089 : overbeek 1.1 push(@$html,&HTML::make_table($col_hdrs,$tab,"Basic Spreadsheet"),
1090 :     $cgi->hr
1091 :     );
1092 :    
1093 :     push(@$html,$cgi->scrolling_list(-name => 'sort',
1094 :     -value => ['unsorted','alphabetic','by_variant','by_phylo','by_tax_id'],
1095 :     -default => 'unsorted'
1096 :     ));
1097 :     }
1098 :     }
1099 :    
1100 : overbeek 1.36 sub format_alternatives {
1101 :     my($cgi,$subsetC,$subsetsC,$col_hdrs,$tab) = @_;
1102 :     my($tab1,$i,%in,$col,$set,%seen,$genome,$row,$cell);
1103 :    
1104 :     my @start = sort { $a <=> $b } keys(%$subsetC);
1105 : overbeek 1.38 my $expand = $cgi->param('ignore_alt');
1106 : overbeek 1.36 my @alt_sets = grep { (! $expand) && ($_ =~ /^\*/) } keys(%$subsetsC);
1107 :     foreach $set (@alt_sets) # map { [ sort { $a <=> $b } keys(%{$subsetsC->{$_}}) ] }
1108 :     {
1109 :     foreach $col (keys(%{$subsetsC->{$set}}))
1110 :     {
1111 :     $in{$col} = $set;
1112 :     }
1113 :     }
1114 :     my $col_hdrsC = [];
1115 :     push(@$col_hdrsC,@{$col_hdrs}[0..2]);
1116 :     for ($i=0; ($i < @start); $i++)
1117 :     {
1118 :     if ($in{$start[$i]})
1119 :     {
1120 :     if (! $seen{$in{$start[$i]}})
1121 :     {
1122 :     push(@$col_hdrsC,$in{$start[$i]});
1123 :     $seen{$in{$start[$i]}} = 1;
1124 :     }
1125 :     }
1126 :     else
1127 :     {
1128 :     push(@$col_hdrsC,$col_hdrs->[$i+3]);
1129 :     }
1130 :     }
1131 :    
1132 :     $tab1 = [];
1133 :     my $x;
1134 :     foreach $x (@$tab)
1135 :     {
1136 :     if ((@$tab1 > 0) && ((@$tab1 % 10) == 0))
1137 :     {
1138 :     push(@$tab1,[map { "<b>$_</b>" } @$col_hdrsC]) ;
1139 :     }
1140 :     $genome = $x->[0]->[0];
1141 :     $row = [$x->[1],$x->[2],$x->[3]];
1142 :     undef %seen;
1143 :     my @pegs = ();
1144 :     my @colors = ();
1145 :     for ($i=0,$cell=0; ($i < @start); $i++)
1146 :     {
1147 :     if ($in{$start[$i]})
1148 :     {
1149 :     if (! defined($seen{$in{$start[$i]}}))
1150 :     {
1151 :     push(@{$pegs[$cell]},&fid_links($cgi,$x->[$i+4],$genome,"-$start[$i]"));
1152 : overbeek 1.39 push(@colors,$x->[$i+4]->[1]);
1153 : overbeek 1.36 $seen{$in{$start[$i]}} = $cell;
1154 :     $cell++;
1155 :     }
1156 :     else
1157 :     {
1158 :     push(@{$pegs[$seen{$in{$start[$i]}}]},&fid_links($cgi,$x->[$i+4],$genome,"-$start[$i]"));
1159 : overbeek 1.39 if (($colors[$seen{$in{$start[$i]}}] eq '#FFFFFF') && ($x->[$i+4]->[1] ne '#FFFFFF'))
1160 :     {
1161 :     $colors[$seen{$in{$start[$i]}}] = $x->[$i+4]->[1];
1162 :     }
1163 : overbeek 1.36 }
1164 :     }
1165 :     else
1166 :     {
1167 :     push(@{$pegs[$cell]},&fid_links($cgi,$x->[$i+4],$genome,""));
1168 : overbeek 1.39 push(@colors,$x->[$i+4]->[1]);
1169 : overbeek 1.36 $cell++;
1170 :     }
1171 :     }
1172 :     my $color = &pick_color(@colors);
1173 : overbeek 1.39 my $j;
1174 :     for ($j=0; ($j < @pegs); $j++)
1175 :     {
1176 :     push(@$row,"\@bgcolor=\"$colors[$j]\"\:" . join("<br>",@{$pegs[$j]}));
1177 :     }
1178 :     # push(@$row,map { "\@bgcolor=\"$color\"\:" . join("<br>",$_ ? @$_ : ()) } @pegs);
1179 : overbeek 1.36 push(@$tab1,$row);
1180 :     }
1181 :     return ($col_hdrsC,$tab1);
1182 :     }
1183 :    
1184 :     sub pick_color {
1185 :     my(@colors) = @_;
1186 :     my($color,$i,@tmp,%count);
1187 :    
1188 :     my %counts;
1189 :     foreach $color (@colors)
1190 :     {
1191 :     $count{$color}++;
1192 :     }
1193 :     @tmp = sort { $count{$b} <=> $count{$a} } keys(%count);
1194 :     for ($i=0; ($i < @tmp) && ($tmp[$i] eq '#FFFFFF'); $i++) {}
1195 :     return ($i == @tmp) ? '#FFFFFF' : $tmp[$i];
1196 :     }
1197 :    
1198 : overbeek 1.1 sub format_existing_rows {
1199 : overbeek 1.36 my($fig,$cgi,$html,$genomes,$rows,$roles,$subsetC,$subsetR,$col_hdrs) = @_;
1200 : overbeek 1.1 my($i,$j,$genome,$row,$entries);
1201 :     my(@tab1);
1202 :    
1203 :     if (@$genomes != @$rows)
1204 :     {
1205 :     print STDERR &Dumper($genomes,$rows); die "mismatch between genomes and rows";
1206 :     }
1207 :    
1208 :     my $iR = 1;
1209 :     for ($i=0; ($i < @$genomes); $i++)
1210 :     {
1211 :     $genome = $genomes->[$i];
1212 :     next if (! $genome);
1213 :     my $vcode_value = $rows->[$i]->[0];
1214 :    
1215 :     my @tmp = ();
1216 :     for ($j=1; ($j < @$roles); $j++)
1217 :     {
1218 :     $rows->[$i]->[$j] = &verify_entry($fig,$genome,$rows->[$i]->[$j]);
1219 :     if ($subsetR->{$genome} && $subsetC->{$j})
1220 :     {
1221 : overbeek 1.6 if ($cgi->param('refill'))
1222 :     {
1223 :     $rows->[$i]->[$j] = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$j,$genome,$roles));
1224 :     }
1225 : overbeek 1.1 elsif ($cgi->param('precise_fill') && (! $rows->[$i]->[$j]))
1226 :     {
1227 :     $rows->[$i]->[$j] = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$j,$genome,$roles));
1228 :     }
1229 :     }
1230 :     $tmp[$j-1] = $rows->[$i]->[$j];
1231 :     }
1232 :    
1233 :     @tmp = &group_by_clusters($fig,$genome,\@tmp);
1234 :    
1235 :     if ($subsetR->{$genome})
1236 :     {
1237 :     my $variant = join("", map { ($_->[0] =~ /\S/) ? 1 : 0 } @tmp);
1238 : overbeek 1.3
1239 :     my($genomeV,$vcodeV);
1240 :     if ($cgi->param('can_alter'))
1241 :     {
1242 :     $genomeV = $cgi->textfield(-name => "genome$iR", -size => 15, -value => $genome, -override => 1);
1243 :     $vcodeV = $cgi->textfield(-name => "vcode$iR", -value => $vcode_value, -size => 5);
1244 :     }
1245 :     else
1246 :     {
1247 :     push(@$html,$cgi->hidden(-name => "genome$iR", -value => $genome, -override => 1),
1248 :     $cgi->hidden(-name => "vcode$iR", -value => $vcode_value));
1249 :     $genomeV = $genome;
1250 :     $vcodeV = $vcode_value;
1251 :     }
1252 :    
1253 : olson 1.21 #
1254 :     # Wrap genomeV in a <a name> tag so we can zing here too.
1255 :     #
1256 :    
1257 :     $genomeV = "<a name=\"$genome\">$genomeV</a>";
1258 :    
1259 : overbeek 1.1 $row = [[$genome,$variant], # key for sorting
1260 : overbeek 1.3 $genomeV,
1261 : overbeek 1.1 &ext_genus_species($fig,$genome),
1262 : overbeek 1.3 $vcodeV
1263 : overbeek 1.1 ];
1264 :     $j = 1;
1265 :     while ($j < @$roles)
1266 :     {
1267 :     if ($roles->[$j])
1268 :     {
1269 :     push(@$html,$cgi->hidden(-name => "row$iR.$j", -value => $tmp[$j-1]->[0], -override => 1));
1270 :     if ($subsetC->{$j})
1271 :     {
1272 : overbeek 1.36 # push(@$row,&fid_links($cgi,$tmp[$j-1],$genome));
1273 :     push(@$row,$tmp[$j-1]);
1274 : overbeek 1.1 }
1275 :     }
1276 :     $j++;
1277 :     }
1278 :     push(@tab1,$row);
1279 :     }
1280 :     else
1281 :     {
1282 :     push(@$html,$cgi->hidden(-name => "genome$iR", -value => $genome, -override => 1),
1283 :     $cgi->hidden(-name => "vcode$iR", -value => $vcode_value, -override => 1)
1284 :     );
1285 :    
1286 :     $j = 1;
1287 :     while ($j < @$roles)
1288 :     {
1289 :     if ($roles->[$j])
1290 :     {
1291 :     push(@$html,$cgi->hidden(-name => "row$iR.$j", -value => $tmp[$j-1]->[0], -override => 1));
1292 :     }
1293 :     $j++;
1294 :     }
1295 :     }
1296 :     $iR++;
1297 :     }
1298 :    
1299 :     my($sort);
1300 :     if ($sort = $cgi->param('sort'))
1301 :     {
1302 :     if ($sort eq "by_variant")
1303 :     {
1304 :     @tab1 = sort { ($a->[0]->[1] cmp $b->[0]->[1]) or ($fig->genus_species($a->[0]->[0]) cmp $fig->genus_species($b->[0]->[0])) } @tab1;
1305 :     }
1306 :     elsif ($sort eq "by_phylo")
1307 :     {
1308 :     @tab1 = map { $_->[0] }
1309 :     sort { $a->[1] cmp $b->[1] }
1310 :     map { [$_, $fig->taxonomy_of($_->[0]->[0])] }
1311 :     @tab1;
1312 :     }
1313 :     elsif ($sort eq "by_tax_id")
1314 :     {
1315 :     @tab1 = map { $_->[0] }
1316 :     sort { $a->[1] <=> $b->[1] }
1317 :     map { [$_, $_->[0]->[0]] }
1318 :     @tab1;
1319 :     }
1320 :     elsif ($sort eq "alphabetic")
1321 :     {
1322 :     @tab1 = map { $_->[0] }
1323 :     sort { $a->[1] cmp $b->[1] }
1324 :     map { [$_, $fig->genus_species($_->[0]->[0])] }
1325 :     @tab1;
1326 :     }
1327 :     }
1328 : overbeek 1.36 return [@tab1];
1329 : overbeek 1.1 }
1330 :    
1331 :     sub format_subsets {
1332 :     my($fig,$cgi,$html,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
1333 :    
1334 :     &format_subsetsC($fig,$cgi,$html,$subsetsC,$active_subsetC);
1335 :     &format_subsetsR($fig,$cgi,$html,$subsetsR,$active_subsetR);
1336 :     }
1337 :    
1338 :     sub format_subsetsC {
1339 :     my($fig,$cgi,$html,$subsetsC,$active_subsetC) = @_;
1340 :     my($i);
1341 :    
1342 :     my $col_hdrs = ["Subset","Includes These Roles"];
1343 :     my $tab = [];
1344 :    
1345 :     my $n = 1;
1346 : overbeek 1.3 &format_existing_subsetsC($cgi,$html,$tab,$subsetsC,\$n);
1347 :     if ($cgi->param('can_alter'))
1348 : overbeek 1.1 {
1349 : overbeek 1.3 for ($i=0; ($i < 5); $i++)
1350 :     {
1351 :     &format_subsetC($cgi,$html,$tab,$n,"");
1352 :     $n++;
1353 :     }
1354 : overbeek 1.1 }
1355 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Subsets of Roles"),
1356 :     $cgi->hr
1357 :     );
1358 :    
1359 :     if (keys(%$subsetsC) > 1)
1360 :     {
1361 :     push(@$html,$cgi->scrolling_list(-name => 'active_subsetC',
1362 :     -values => [sort keys(%$subsetsC)],
1363 :     -default => $active_subsetC
1364 :     ),
1365 :     $cgi->br
1366 :     );
1367 :     }
1368 :     else
1369 :     {
1370 :     push(@$html,$cgi->hidden(-name => 'active_subsetC', -value => $active_subsetC, -override => 1));
1371 :     }
1372 :     }
1373 :    
1374 :     sub format_subsetsR {
1375 :     my($fig,$cgi,$html,$subsets,$active_subsetR) = @_;
1376 :     my($i);
1377 :    
1378 :     my $link = &tree_link;
1379 :     push(@$html,$cgi->br,$link,$cgi->br);
1380 :    
1381 :     my @tmp = grep { $_ ne "All" } sort keys(%$subsets);
1382 :     push(@$html,$cgi->scrolling_list(-name => 'active_subsetR',
1383 :     -values => ["All",@tmp],
1384 :     -default => $active_subsetR,
1385 :     -size => 5
1386 :     ),
1387 :     $cgi->br
1388 :     );
1389 :     }
1390 :    
1391 :     sub format_existing_subsetsC {
1392 : overbeek 1.3 my($cgi,$html,$tab,$subsetsC,$nP) = @_;
1393 : overbeek 1.1 my($nameCS);
1394 :    
1395 :     foreach $nameCS (sort keys(%$subsetsC))
1396 :     {
1397 : overbeek 1.3 &format_subsetC($cgi,$html,$tab,$$nP,$nameCS,$subsetsC->{$nameCS});
1398 : overbeek 1.1 $$nP++;
1399 :     }
1400 :     }
1401 :    
1402 :     sub format_subsetC {
1403 : overbeek 1.3 my($cgi,$html,$tab,$n,$nameCS,$subsetC) = @_;
1404 : overbeek 1.1
1405 :     if ($nameCS ne "All")
1406 :     {
1407 :     my $subset = join(",",sort { $a <=> $b } keys(%$subsetC));
1408 : overbeek 1.3 my($posT,$subsetT);
1409 :     if ($cgi->param('can_alter'))
1410 :     {
1411 :     $posT = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1);
1412 :     $subsetT = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1);
1413 :     }
1414 :     else
1415 :     {
1416 :     push(@$html,$cgi->hidden(-name => "nameCS$n", -value => $nameCS, -override => 1),
1417 :     $cgi->hidden(-name => "subsetC$n", -value => $subset, -override => 1));
1418 :     $posT = $nameCS;
1419 :     $subsetT = $subset;
1420 :     }
1421 : overbeek 1.1 push(@$tab,[$posT,$subsetT]);
1422 :     }
1423 :     }
1424 :    
1425 :     sub format_roles {
1426 :     my($fig,$cgi,$html,$roles,$genomes,$rows) = @_;
1427 :     my($i);
1428 :    
1429 : mkubal 1.47 my $col_hdrs = ["Column","Abbrev","Functional Role","Other Subsystems with this Role"];
1430 : overbeek 1.1 my $tab = [];
1431 :    
1432 :     my $n = 1;
1433 : overbeek 1.3 &format_existing_roles($fig,$cgi,$html,$tab,$roles,\$n,$genomes,$rows);
1434 :     if ($cgi->param('can_alter'))
1435 : overbeek 1.1 {
1436 : overbeek 1.3 for ($i=0; ($i < 5); $i++)
1437 :     {
1438 :     &format_role($fig,$cgi,$html,$tab,$n,"",$roles,$genomes,$rows);
1439 :     $n++;
1440 :     }
1441 : overbeek 1.1 }
1442 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Functional Roles"),
1443 :     $cgi->hr
1444 :     );
1445 :     }
1446 :    
1447 :     sub format_existing_roles {
1448 : overbeek 1.3 my($fig,$cgi,$html,$tab,$roles,$nP,$genomes,$rows) = @_;
1449 : overbeek 1.1 my($role,$i);
1450 :    
1451 :     for ($i=1; ($i < @$roles); $i++)
1452 :     {
1453 :     $role = $roles->[$i];
1454 : overbeek 1.3 &format_role($fig,$cgi,$html,$tab,$$nP,$role,$roles,$genomes,$rows);
1455 : overbeek 1.1 $$nP++;
1456 :     }
1457 :     }
1458 :    
1459 :     sub format_role {
1460 : overbeek 1.3 my($fig,$cgi,$html,$tab,$n,$role,$roles,$genomes,$rows) = @_;
1461 : mkubal 1.47 my($abbrev,$text,$other_ss_text,$r,$ss_list,$new_text);
1462 :     my($ss_hash);
1463 :     my($posT,$abbrevT,$roleT,$otherSS);
1464 : overbeek 1.1
1465 :     if ($role =~ /^(.*)\t(.*)$/)
1466 :     {
1467 :     $abbrev = $1;
1468 :     $text = $2;
1469 :     }
1470 :     else
1471 :     {
1472 :     $abbrev = "";
1473 :     $text = $role;
1474 :     }
1475 :    
1476 : mkubal 1.47 $ss_hash = $fig->subsystem_roles();
1477 :    
1478 :     $new_text = $text;
1479 :    
1480 :     $other_ss_text = "None";
1481 :    
1482 :     foreach $r (keys(%$ss_hash)){
1483 :     if ($r eq $new_text ){
1484 :     $ss_list = $ss_hash->{$r};
1485 :     $other_ss_text = join(",",@$ss_list);
1486 :     #$other_ss_text = "new";
1487 :     }
1488 :     }
1489 :    
1490 : overbeek 1.3 if ($cgi->param('can_alter'))
1491 :     {
1492 :     $posT = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1);
1493 :     $abbrevT = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1);
1494 :     $roleT = $cgi->textfield(-name => "role$n", -size => 80, -value => $text, -override => 1);
1495 : mkubal 1.47 $otherSS = $cgi->textfield(-name => "role$n", -size => 80, -value => $other_ss_text, -override => 1);
1496 : overbeek 1.3 }
1497 :     else
1498 :     {
1499 :     push(@$html,$cgi->hidden(-name => "posR$n", -value => $n, -override => 1),
1500 :     $cgi->hidden(-name => "abbrev$n", -value => $abbrev, -override => 1),
1501 : mkubal 1.47 $cgi->hidden(-name => "role$n", -value => $text, -override => 1),
1502 :     $cgi->hidden(-name => "role$n", -value => $other_ss_text, -override => 1)
1503 :     );
1504 :    
1505 : overbeek 1.3 $posT = $n;
1506 :     $abbrevT = $abbrev;
1507 :     $roleT = $text;
1508 : mkubal 1.47 $otherSS = $other_ss_text;
1509 : overbeek 1.3 }
1510 : olson 1.21 #
1511 :     # Wrap the first element in the table with a <A NAME="role_rolename"> tag
1512 :     # so we can zing to it from elsewhere. We remove any non-alphanumeric
1513 :     # chars in the role name.
1514 :     #
1515 :    
1516 :     my $posT_html;
1517 :     {
1518 :     my $rn = $text;
1519 : overbeek 1.26 $rn =~ s/[ \/]/_/g;
1520 : olson 1.21 $rn =~ s/\W//g;
1521 :    
1522 :     $posT_html = "<a name=\"$rn\">$posT</a>";
1523 :     }
1524 : mkubal 1.47
1525 :    
1526 :     push(@$tab,[$posT_html,$abbrevT,$roleT,$otherSS]);
1527 : overbeek 1.24
1528 : overbeek 1.36 if ($cgi->param('check_problems'))
1529 : overbeek 1.1 {
1530 : overbeek 1.36 my @roles = grep { $_->[0] ne $text } &gene_functions_in_col($fig,$n,$roles,$genomes,$rows);
1531 :     my($x,$peg);
1532 :     foreach $x (@roles)
1533 : overbeek 1.1 {
1534 : overbeek 1.36 push(@$tab,["","",$x->[0]]);
1535 : overbeek 1.24 push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]);
1536 : overbeek 1.1 }
1537 :     }
1538 :     }
1539 :    
1540 : overbeek 1.36
1541 : overbeek 1.1 sub write_spreadsheet_from_input_parameters {
1542 :     my($fig,$cgi,$html,$ssa,$user) = @_;
1543 :     my($i,$j,$pos,$role,$subset,@roles,$genome,$row,$nameCS,$nameRS,%role_map,%role_map2);
1544 :     my($param,@param,@tmp,$active_subsetC,$pair);
1545 :    
1546 :     my $roles = [];
1547 :     my $genomes = [];
1548 :     my $rows = [];
1549 :     my $subsetsC = {};
1550 :     my $active_subsetC = "All";
1551 :     my $subsetsR = {};
1552 :     my $active_subsetR = "All";
1553 :    
1554 : overbeek 1.3 if ($cgi->param('can_alter'))
1555 :     {
1556 :     &log_update($ssa,$user);
1557 : overbeek 1.1
1558 : overbeek 1.3 if (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet")
1559 : overbeek 1.1 {
1560 : overbeek 1.3 rename("$FIG_Config::data/Subsystems/$ssa/spreadsheet","$FIG_Config::data/Subsystems/$ssa/spreadsheet~");
1561 : overbeek 1.31 }
1562 :    
1563 :     if ($cgi->param('notes'))
1564 :     {
1565 : overbeek 1.3 if (-s "$FIG_Config::data/Subsystems/$ssa/notes")
1566 :     {
1567 :     rename("$FIG_Config::data/Subsystems/$ssa/notes","$FIG_Config::data/Subsystems/$ssa/notes~");
1568 :     }
1569 :     else
1570 :     {
1571 :     open(NOTES,">$FIG_Config::data/Subsystems/$ssa/notes");
1572 :     close(NOTES);
1573 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
1574 :     }
1575 : overbeek 1.1 }
1576 : overbeek 1.31 elsif (-s "$FIG_Config::data/Subsystems/$ssa/notes")
1577 :     {
1578 :     my $notes = &FIG::file_read("$FIG_Config::data/Subsystems/$ssa/notes");
1579 :     $cgi->param(-name => "notes", -value => $notes);
1580 :     }
1581 : overbeek 1.3
1582 :     open(SSA,">$FIG_Config::data/Subsystems/$ssa/spreadsheet")
1583 :     || die "could not open $FIG_Config::data/Subsystems/$ssa/spreadsheet";
1584 : overbeek 1.1 }
1585 :     @param = grep { $_ =~ /^posR/ } $cgi->param;
1586 :     foreach $param (@param)
1587 :     {
1588 :     if ($param =~ /^posR(\d+)/)
1589 :     {
1590 :     $i = $1;
1591 :     if (($pos = $cgi->param("posR$i")) && ($role = $cgi->param("role$i")))
1592 :     {
1593 :     $role =~ s/^\s+//;
1594 :     $role =~ s/\s+$//;
1595 :     if ($role =~ /\S/)
1596 :     {
1597 :     if ($_ = $cgi->param("abbrev$i"))
1598 :     {
1599 :     $tmp[$pos] = "$_\t$role";
1600 :     }
1601 :     else
1602 :     {
1603 :     $tmp[$pos] = "\t$role";
1604 :     }
1605 :     $role_map2{$pos} = $i;
1606 :     }
1607 :     }
1608 :     }
1609 :     }
1610 :    
1611 :     $j = 1;
1612 :     foreach $pos (sort { $a <=> $b } keys(%role_map2))
1613 :     {
1614 :     $roles->[$j] = $tmp[$pos];
1615 :     $role_map{$role_map2{$pos}} = $j;
1616 :     $j++;
1617 :     }
1618 :    
1619 : overbeek 1.3 if ($cgi->param('can_alter'))
1620 : overbeek 1.1 {
1621 : overbeek 1.3 foreach $role (@$roles)
1622 : overbeek 1.1 {
1623 : overbeek 1.3 if ($role)
1624 :     {
1625 :     print SSA "$role\n";
1626 :     }
1627 : overbeek 1.1 }
1628 : overbeek 1.3 print SSA "//\n";
1629 : overbeek 1.1 }
1630 :    
1631 :     @param = grep { $_ =~ /^nameCS/ } $cgi->param;
1632 :     foreach $param (@param)
1633 :     {
1634 :     if ($param =~ /^nameCS(\d+)/)
1635 :     {
1636 :     $i = $1;
1637 :     if (($nameCS = $cgi->param("nameCS$i")) && ($subset = $cgi->param("subsetC$i")))
1638 :     {
1639 : overbeek 1.29 $nameCS =~ s/ /_/g;
1640 :     $subset =~ s/^\s+//;
1641 : overbeek 1.30 $subset =~ s/\s+$//;
1642 : overbeek 1.29
1643 : overbeek 1.1 foreach $_ (split(/[\t ,;]+/,$subset))
1644 :     {
1645 :     if ($_ =~ /^\d+$/)
1646 :     {
1647 :     $subsetsC->{$nameCS}->{$role_map{$_}} = 1;
1648 :     }
1649 :     }
1650 :     }
1651 :     }
1652 :     }
1653 :    
1654 :     foreach $nameCS (sort keys(%$subsetsC))
1655 :     {
1656 :     $subset = $subsetsC->{$nameCS};
1657 :     if ($subset)
1658 :     {
1659 :     @roles = sort { $a <=> $b } keys(%$subset);
1660 :     }
1661 :    
1662 : overbeek 1.3 if ($cgi->param('can_alter'))
1663 : overbeek 1.1 {
1664 : overbeek 1.29 if (@roles > 0)
1665 : overbeek 1.3 {
1666 :     print SSA join("\t",($nameCS,@roles)),"\n";
1667 :     }
1668 :     else
1669 :     {
1670 :     push(@$html,$cgi->h2("invalid subset: $subset"));
1671 :     }
1672 : overbeek 1.1 }
1673 :     }
1674 :    
1675 :     if (! ($active_subsetC = $cgi->param('active_subsetC')))
1676 :     {
1677 :     $active_subsetC = "All";
1678 :     }
1679 :    
1680 :     if (! $subsetsC->{"All"})
1681 :     {
1682 :     for ($i=1; ($i < @$roles); $i++)
1683 :     {
1684 :     $subsetsC->{"All"}->{$i} = 1;
1685 :     }
1686 :     }
1687 : overbeek 1.3 if ($cgi->param('can_alter'))
1688 :     {
1689 :     print SSA "$active_subsetC\n";
1690 :     print SSA "\n";
1691 :     }
1692 : overbeek 1.1
1693 :    
1694 :     my($taxonomic_groups,$id,$members,$genome);
1695 :     $taxonomic_groups = $fig->taxonomic_groups_of_complete(10);
1696 :     foreach $pair (@$taxonomic_groups)
1697 :     {
1698 :     ($id,$members) = @$pair;
1699 :     foreach $genome (@$members)
1700 :     {
1701 :     $subsetsR->{$id}->{$genome} = 1;
1702 :     }
1703 :     }
1704 :    
1705 :     $active_subsetR = $cgi->param('active_subsetR');
1706 :     if (! ($active_subsetR && $subsetsR->{$active_subsetR}))
1707 :     {
1708 :     $active_subsetR = &default_genome_set;
1709 :     }
1710 : overbeek 1.3 if ($cgi->param('can_alter'))
1711 :     {
1712 :     print SSA "$active_subsetR\n";
1713 :     print SSA "//\n";
1714 :     }
1715 : overbeek 1.1
1716 :     $i = 1;
1717 :     while (defined($genome = $cgi->param("genome$i")))
1718 :     {
1719 :     if ($genome =~ /^\d+\.\d+$/)
1720 :     {
1721 :     $genomes->[$i-1] = $genome;
1722 :     }
1723 :     $i++;
1724 :     }
1725 :    
1726 :     $i = 1;
1727 :     my($vcode_value,$j,$row,$entry,$non_null);
1728 :     while (defined($vcode_value = $cgi->param("vcode$i")))
1729 :     {
1730 :     if ($genomes->[$i-1])
1731 :     {
1732 :     $row = [$vcode_value];
1733 :     for ($j=1; ($j < (@$roles + 5)); $j++)
1734 :     {
1735 :     if ($role_map{$j})
1736 :     {
1737 :     if ($entry = $cgi->param("row$i.$j"))
1738 :     {
1739 :     $row->[$role_map{$j}] = $entry;
1740 :     }
1741 :     else
1742 :     {
1743 :     $row->[$role_map{$j}] = "";
1744 :     }
1745 :     }
1746 :     }
1747 :     $rows->[$i-1] = $row;
1748 : overbeek 1.3 if ($cgi->param('can_alter'))
1749 :     {
1750 :     print SSA join("\t",($genomes->[$i-1],@$row)),"\n";
1751 :     }
1752 : overbeek 1.1 }
1753 :     $i++;
1754 :     }
1755 :    
1756 :     my @orgs = $cgi->param('korgs');
1757 :     @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
1758 :    
1759 : overbeek 1.3 if ($cgi->param('can_alter'))
1760 : overbeek 1.1 {
1761 : overbeek 1.3 my @orgs1 = ();
1762 :     if ($cgi->param('add_solid'))
1763 :     {
1764 :     my %genomes1 = map { $_ => 1 } (@$genomes,@orgs);;
1765 :     @orgs1 = sort grep { ! $genomes1{$_} } $fig->genomes("complete",undef);
1766 :     }
1767 :     &extend_ssa($fig,$genomes,$roles,$rows,\@orgs,\@orgs1,\*SSA);
1768 :    
1769 :    
1770 :     close(SSA);
1771 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet");
1772 :     if (($_ = $cgi->param('notes')) && open(NOTES,">$FIG_Config::data/Subsystems/$ssa/notes"))
1773 :     {
1774 :     print NOTES $_;
1775 :     close(NOTES);
1776 :     }
1777 :     &backup("$FIG_Config::data/Subsystems/$ssa");
1778 : overbeek 1.1
1779 :     }
1780 : overbeek 1.3 # print &Dumper($roles,$subsets,$genomes,$rows); die "aborted";
1781 : olson 1.13
1782 :     #
1783 :     # Update the subsystem index.
1784 :     #
1785 :     # (Put this in an eval in case we get a failure here).
1786 :     #
1787 :    
1788 :     eval {
1789 :     my $sub = $fig->get_subsystem($ssa, 1);
1790 :     $sub->db_sync();
1791 :     };
1792 :    
1793 : overbeek 1.1 return ($roles,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR,$genomes,$rows);
1794 :     }
1795 :    
1796 :     sub format_ssa_table {
1797 : overbeek 1.3 my($cgi,$html,$user,$ssaP) = @_;
1798 : overbeek 1.1 my($ssa,$curator);
1799 :     my($url1,$link1);
1800 :    
1801 : overbeek 1.3 my $can_alter = $cgi->param('can_alter');
1802 : overbeek 1.2 push(@$html, $cgi->start_form(-action => "ssa2.cgi",
1803 : overbeek 1.1 -method => 'post'),
1804 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
1805 : overbeek 1.3 $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
1806 : overbeek 1.1 $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1)
1807 :     );
1808 : overbeek 1.4 push(@$html,"<font size=\"+2\">Please do not ever edit someone else\'s spreadsheet (by using their
1809 :     user ID), and <b>never open multiple windows to
1810 : overbeek 1.3 process the same spreadsheet</b></font>. It is, of course, standard practice to open a subsystem
1811 : overbeek 1.4 spreadsheet and then to have multiple other SEED windows to access data and modify annotations. Further,
1812 :     you can access someone else's subsystem spreadsheet using your ID (which will make it impossible
1813 :     for you to edit the spreadsheet).
1814 :     Just do not open the same subsystem spreadsheet for editing in multiple windows simultaneously.",
1815 : overbeek 1.3 $cgi->br,
1816 :     $cgi->br
1817 :     );
1818 : overbeek 1.1
1819 : olson 1.8 my $col_hdrs = [
1820 :     "Name","Curator","Exchangable","Version",
1821 :     "Reset to Previous Timestamp","Delete",
1822 :     "Export Full Subsystem","Export Just Assignments", "Publish to Clearinghouse",
1823 :     ];
1824 : overbeek 1.1 my $title = "Existing Subsystem Annotations";
1825 :     my $tab = [];
1826 :     foreach $_ (@$ssaP)
1827 :     {
1828 : olson 1.19 my($publish_checkbox);
1829 : overbeek 1.1 ($ssa,$curator) = @$_;
1830 : olson 1.19
1831 : overbeek 1.1 my($url,$link);
1832 : overbeek 1.3 if ((-d "$FIG_Config::data/Subsystems/$ssa/Backup") && ($curator eq $cgi->param('user')))
1833 : overbeek 1.1 {
1834 : overbeek 1.2 $url = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=reset";
1835 : overbeek 1.1 $link = "<a href=$url>reset</a>";
1836 :     }
1837 :     else
1838 :     {
1839 : overbeek 1.3 $link = "";
1840 : overbeek 1.1 }
1841 :    
1842 : overbeek 1.3 if (($fig->is_exchangable_subsystem($ssa)) && ($curator eq $cgi->param('user')))
1843 : overbeek 1.1 {
1844 : overbeek 1.2 $url1 = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=make_unexchangable";
1845 : overbeek 1.1 $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>";
1846 :     }
1847 : overbeek 1.3 elsif ($curator eq $cgi->param('user'))
1848 : overbeek 1.1 {
1849 : overbeek 1.2 $url1 = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=make_exchangable";
1850 : overbeek 1.1 $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>";
1851 :     }
1852 : overbeek 1.3 else
1853 :     {
1854 :     $link1 = "";
1855 :     }
1856 : olson 1.8
1857 :     #
1858 :     # Only allow publish for subsystems we are curating?
1859 :     #
1860 : olson 1.12 if ($curator eq $cgi->param('user'))
1861 : olson 1.8 {
1862 :     $publish_checkbox = $cgi->checkbox(-name => "publish_to_clearinghouse",
1863 :     -value => $ssa,
1864 :     -label => "Publish"),
1865 :    
1866 :     }
1867 : overbeek 1.1
1868 : olson 1.8 push(@$tab,[
1869 : overbeek 1.1 &ssa_link($ssa,$user),
1870 :     $curator,
1871 :     $link1,
1872 : olson 1.8 $fig->subsystem_version($ssa),
1873 :     $link,
1874 :     ($curator eq $cgi->param('user')) ? $cgi->checkbox(-name => "delete", -value => $ssa) : "",
1875 :     $cgi->checkbox(-name => "export", -value => $ssa, -label => "Export full"),
1876 :     $cgi->checkbox(-name => "export_assignments", -value => $ssa, -label => "Export assignments"),
1877 :     $publish_checkbox,
1878 : overbeek 1.1 ]);
1879 :     }
1880 : olson 1.8 push(@$html,
1881 :     &HTML::make_table($col_hdrs,$tab,$title),
1882 :     $cgi->submit(-name => 'delete_export',
1883 :     -label => 'Process marked deletions and exports'),
1884 :     $cgi->submit(-name => 'publish',
1885 :     -label => "Publish marked subsystems"),
1886 :     $cgi->end_form
1887 : overbeek 1.1 );
1888 :     }
1889 :    
1890 :     sub ssa_link {
1891 :     my($ssa,$user) = @_;
1892 :     my $name = $ssa; $name =~ s/_/ /g;
1893 :     my $target = "window$$";
1894 : overbeek 1.3 my $can_alter = &curator($ssa) eq $user;
1895 :    
1896 :     my $url = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=show_ssa&can_alter=$can_alter";
1897 : overbeek 1.1 return "<a href=$url target=$target>$name</a>";
1898 :     }
1899 :    
1900 :     sub tree_link {
1901 :     my $target = "window$$";
1902 : overbeek 1.2 my $url = &FIG::cgi_url . "/ssa2.cgi?request=show_tree";
1903 : overbeek 1.1 return "<a href=$url target=$target>Show Phylogenetic Tree</a>";
1904 :     }
1905 :    
1906 :    
1907 :     sub existing_subsystem_annotations {
1908 :     my($ssa,$name);
1909 :     my @ssa = ();
1910 :     if (opendir(SSA,"$FIG_Config::data/Subsystems"))
1911 :     {
1912 : overbeek 1.26 @ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/[ \/]/_/g; [$name,&curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA);
1913 : overbeek 1.1 closedir(SSA);
1914 :     }
1915 : overbeek 1.25 return sort { $a->[0] cmp $b->[0] } @ssa;
1916 : overbeek 1.1 }
1917 :    
1918 :     sub curator {
1919 :     my($ssa) = @_;
1920 :     my($who) = "";
1921 :    
1922 :     if (open(DATA,"<$FIG_Config::data/Subsystems/$ssa/curation.log"))
1923 :     {
1924 :     $_ = <DATA>;
1925 :     if ($_ =~ /^\d+\t(\S+)\s+started/)
1926 :     {
1927 :     $who = $1;
1928 :     }
1929 :     close(DATA);
1930 :     }
1931 :     return $who;
1932 :     }
1933 :    
1934 :     sub log_update {
1935 :     my($ssa,$user) = @_;
1936 :    
1937 : overbeek 1.26 $ssa =~ s/[ \/]/_/g;
1938 : overbeek 1.1
1939 :     if (open(LOG,">>$FIG_Config::data/Subsystems/$ssa/curation.log"))
1940 :     {
1941 :     my $time = time;
1942 :     print LOG "$time\t$user\tupdated\n";
1943 :     close(LOG);
1944 :     }
1945 :     else
1946 :     {
1947 :     print STDERR "failed to open $FIG_Config::data/Subsystems/$ssa/curation.log\n";
1948 :     }
1949 :     }
1950 :    
1951 :     sub extend_ssa {
1952 :     my($fig,$genomes,$roles,$rows,$new_genomes,$poss_new_genomes,$fh) = @_;
1953 :     my($genome,$i,$row,$role);
1954 :    
1955 :     foreach $genome (@$new_genomes)
1956 :     {
1957 :     push(@$genomes,$genome);
1958 :     $row = [0];
1959 :     for ($i=1; ($i < @$roles); $i++)
1960 :     {
1961 :     push(@$row,join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$i,$genome,$roles)));
1962 :     }
1963 :     push(@$rows,$row);
1964 :     print $fh join("\t",($genome,@$row)),"\n";
1965 :     }
1966 :    
1967 :     foreach $genome (@$poss_new_genomes)
1968 :     {
1969 :     $row = [0];
1970 :     my $bad = 0;
1971 :     for ($i=1; ($i < @$roles); $i++)
1972 :     {
1973 :     my $entry = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$i,$genome,$roles));
1974 :     if (! $entry)
1975 :     {
1976 :     $bad = 1;
1977 :     last;
1978 :     }
1979 :     push(@$row,$entry);
1980 :     }
1981 :     if (! $bad)
1982 :     {
1983 :     push(@$genomes,$genome);
1984 :     push(@$rows,$row);
1985 :     print $fh join("\t",($genome,@$row)),"\n";
1986 :     }
1987 :     }
1988 :     }
1989 : golsen 1.48
1990 :    
1991 : overbeek 1.1 sub seqs_with_role_precisely {
1992 :     my($fig,$i,$genome,$roles) = @_;
1993 :    
1994 :     # The $i parm is a bit weird. The actual role we want is in $roles->[$i]. Any existing versions are in
1995 :     # $rows->[*]->[$i] entries. You look for acceptable roles matching $roles->[$i] (after tab)
1996 :    
1997 :     my @pegs = ();
1998 :     if ($roles->[$i] =~ /([^\t]+)$/)
1999 :     {
2000 :     @pegs = $fig->seqs_with_role($1,"master",$genome);
2001 :     }
2002 :     return @pegs;
2003 :     }
2004 :    
2005 :     sub gene_functions_in_col {
2006 :     my($fig,$i,$roles,$genomes,$rows) = @_;
2007 :     my(%roles,$j,$row,$genomeJ,$entry,@pegs,$peg,$func);
2008 :    
2009 :     if ($roles->[$i] =~ /([^\t]+)$/)
2010 :     {
2011 :     $roles{$1} = [];
2012 :     }
2013 :    
2014 :     for ($j=0; ($j < @$rows); $j++)
2015 :     {
2016 :     $row = $rows->[$j];
2017 :     $genomeJ = $genomes->[$j];
2018 :     if ($row->[$i] =~ /(\S.*\S)/)
2019 :     {
2020 :     $entry = $1;
2021 :     @pegs = map { "fig|$genomeJ.peg.$_" } split(/,/,$entry);
2022 :     foreach $peg (@pegs)
2023 :     {
2024 :     if ($func = $fig->function_of($peg))
2025 :     {
2026 :     push(@{$roles{$func}},$peg);
2027 :     }
2028 :     }
2029 :     }
2030 :     }
2031 :     return map { [$_,$roles{$_}] } sort keys(%roles);
2032 :     }
2033 :    
2034 :    
2035 :     sub verify_entry {
2036 :     my($fig,$genome,$entry) = @_;
2037 :     my($peg);
2038 :    
2039 :     my @verified = ();
2040 :     foreach $peg (split(/[, \t]+/,$entry))
2041 :     {
2042 :     if ($fig->is_real_feature("fig|$genome.peg.$peg"))
2043 :     {
2044 :     push(@verified,$peg);
2045 :     }
2046 :     }
2047 :     return join(",",@verified);
2048 :     }
2049 :    
2050 :     sub export {
2051 :     my($fig,$cgi,$ssa) = @_;
2052 :     my($line);
2053 :    
2054 :     my ($exportable,$notes) = $fig->exportable_subsystem($ssa);
2055 :     foreach $line (@$exportable,@$notes)
2056 :     {
2057 :     print $line;
2058 :     }
2059 :     }
2060 :    
2061 :     sub export_assignments {
2062 :     my($fig,$cgi,$ssa) = @_;
2063 :     my(@roles,$i,$entry,$id,$user);
2064 :    
2065 :     if (($user = $cgi->param('user')) && open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
2066 :     {
2067 :     $user =~ s/^master://;
2068 :     &FIG::verify_dir("$FIG_Config::data/Assignments/$user");
2069 :     my $who = &curator($ssa);
2070 :     my $file = &FIG::epoch_to_readable(time) . ":$who:generated_from_subsystem_$ssa";
2071 :    
2072 :     if (open(OUT,">$FIG_Config::data/Assignments/$user/$file"))
2073 :     {
2074 :     while (defined($_ = <SSA>) && ($_ !~ /^\/\//))
2075 :     {
2076 :     chop;
2077 :     push(@roles,$_);
2078 :     }
2079 :     while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) {}
2080 :     while (defined($_ = <SSA>))
2081 :     {
2082 :     chop;
2083 :     my @flds = split(/\t/,$_);
2084 :     my $genome = $flds[0];
2085 :     for ($i=2; ($i < @flds); $i++)
2086 :     {
2087 :     my @entries = split(/,/,$flds[$i]);
2088 :     foreach $id (@entries)
2089 :     {
2090 :     my $peg = "fig|$genome.peg.$id";
2091 :     my $func = $fig->function_of($peg);
2092 :     print OUT "$peg\t$func\n";
2093 :     }
2094 :     }
2095 :     }
2096 :     close(OUT);
2097 :     }
2098 :     close(SSA);
2099 :     }
2100 :     }
2101 :    
2102 :     sub format_missing {
2103 :     my($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
2104 :     my($i,$j,$missing,$user,$role,$org,$link,$genus_species,$abr);
2105 :    
2106 :     my $subsetC = $subsetsC->{$active_subsetC};
2107 :     my $subsetR = $subsetsR->{$active_subsetR};
2108 :    
2109 : overbeek 1.37 my @alt_sets = grep { ($_ =~ /^\*/) } keys(%$subsetsC);
2110 :     my($set,$col,%in);
2111 :     foreach $set (@alt_sets)
2112 :     {
2113 :     foreach $col (keys(%{$subsetsC->{$set}}))
2114 :     {
2115 :     $in{$col} = $set;
2116 :     }
2117 :     }
2118 : overbeek 1.1 push(@$html,$cgi->h1('To Check Missing Entries:'));
2119 :    
2120 :     for ($i=0; ($i < @$rows); $i++)
2121 :     {
2122 :     $org = $genomes->[$i];
2123 :     next if (! $subsetR->{$org});
2124 : overbeek 1.38 my @missing = &columns_missing_entries($cgi,$subsetsC,$subsetC,$rows,$i,$roles,\%in);
2125 : overbeek 1.1
2126 :     $missing = [];
2127 : overbeek 1.37 foreach $j (@missing)
2128 : overbeek 1.1 {
2129 : overbeek 1.37 $user = $cgi->param('user');
2130 :     $role = $roles->[$j];
2131 :     if ($role =~ /^(.*)\t(.*)$/)
2132 :     {
2133 :     ($abr,$role) = ($1,$2);
2134 :     }
2135 :     else
2136 : overbeek 1.1 {
2137 : overbeek 1.37 $abr = "";
2138 : overbeek 1.1 }
2139 : overbeek 1.37 my $roleE = $cgi->escape($role);
2140 :    
2141 :     $link = "<a href=" . &FIG::cgi_url . "/pom.cgi?user=$user&request=find_in_org&role=$roleE&org=$org>$abr $role</a>";
2142 :     push(@$missing,$link);
2143 : overbeek 1.1 }
2144 : overbeek 1.37
2145 : overbeek 1.1 if (@$missing > 0)
2146 :     {
2147 :     $genus_species = &ext_genus_species($fig,$org);
2148 :     push(@$html,$cgi->h2("$org: $genus_species"));
2149 :     push(@$html,$cgi->ul($cgi->li($missing)));
2150 : overbeek 1.37 }
2151 :     }
2152 :     }
2153 :    
2154 :     sub columns_missing_entries {
2155 : overbeek 1.38 my($cgi,$subsetsC,$subsetC,$rows,$i,$roles,$in) = @_;
2156 : overbeek 1.37 my(%missing_cols,$j,$k);
2157 :     my(@really_missing) = ();
2158 : olson 1.15
2159 : overbeek 1.37 for ($j=1; ($j < @$roles); $j++)
2160 :     {
2161 :     if (! $rows->[$i]->[$j])
2162 :     {
2163 :     $missing_cols{$j} = 1;
2164 : olson 1.15 }
2165 : overbeek 1.37 }
2166 : olson 1.15
2167 : overbeek 1.37 for ($j=1; ($j < @$roles); $j++)
2168 :     {
2169 :     if ($missing_cols{$j} && $subsetC->{$j})
2170 :     {
2171 :     my($set);
2172 : overbeek 1.38 if (($set = $in->{$j}) && (! $cgi->param('ignore_alt')))
2173 : overbeek 1.37 {
2174 :     my @set = keys(%{$subsetsC->{$set}});
2175 :     for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
2176 :     if ($k == @set)
2177 :     {
2178 :     push(@really_missing,$j);
2179 :     }
2180 :     }
2181 :     else
2182 :     {
2183 :     push(@really_missing,$j);
2184 :     }
2185 :     }
2186 : olson 1.15 }
2187 : overbeek 1.37 return @really_missing;
2188 : olson 1.15 }
2189 :    
2190 :     sub format_missing_including_matches
2191 :     {
2192 :     my($fig,$cgi,$html,$genomes,$roles,$rows,
2193 :     $subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
2194 :    
2195 :     my($i,$j,$missing,$user,$role,$org,$link,$genus_species,$abr);
2196 :    
2197 :     my $subsetC = $subsetsC->{$active_subsetC};
2198 :     my $subsetR = $subsetsR->{$active_subsetR};
2199 :    
2200 : overbeek 1.38 my @alt_sets = grep { ($_ =~ /^\*/) } keys(%$subsetsC);
2201 :     my($set,$col,%in);
2202 :     foreach $set (@alt_sets)
2203 :     {
2204 :     foreach $col (keys(%{$subsetsC->{$set}}))
2205 :     {
2206 :     $in{$col} = $set;
2207 :     }
2208 :     }
2209 :    
2210 : olson 1.15 push(@$html,$cgi->h1('To Check Missing Entries:'));
2211 :    
2212 : olson 1.16 push(@$html, $cgi->start_form(-action=> "fid_checked.cgi"));
2213 :    
2214 :     my $can_alter = $cgi->param('can_alter');
2215 :     $user = $cgi->param('user');
2216 :     push(@$html,
2217 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
2218 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1));
2219 :    
2220 : olson 1.15 for ($i=0; ($i < @$rows); $i++)
2221 :     {
2222 :     $org = $genomes->[$i];
2223 : overbeek 1.24 next if (($_ = $cgi->param('just_genome')) && ($org != $_));
2224 : olson 1.15 next if (! $subsetR->{$org});
2225 : overbeek 1.24
2226 : overbeek 1.38 my @missing = &columns_missing_entries($cgi,$subsetsC,$subsetC,$rows,$i,$roles,\%in);
2227 :    
2228 : olson 1.15 $missing = [];
2229 :    
2230 : overbeek 1.38 foreach $j (@missing)
2231 : olson 1.15 {
2232 : overbeek 1.38 $role = $roles->[$j];
2233 :     if ($role =~ /^(.*)\t(.*)$/)
2234 :     {
2235 :     ($abr,$role) = ($1,$2);
2236 :     }
2237 :     else
2238 : olson 1.15 {
2239 : overbeek 1.38 $abr = "";
2240 :     }
2241 :     my $roleE = $cgi->escape($role);
2242 : olson 1.15
2243 :     #
2244 : olson 1.16 # All the way up to here is code to retrieve the role name.
2245 : olson 1.15 #
2246 :    
2247 :     #
2248 :     # Invoke find_role_in_org to get the roles we might have.
2249 :     #
2250 :    
2251 : overbeek 1.38 my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff"));
2252 : olson 1.15
2253 : overbeek 1.38 push(@$missing,@hits);
2254 : olson 1.15 }
2255 :     $genus_species = &ext_genus_species($fig,$org);
2256 :     push(@$html,$cgi->h2("$org: $genus_species"));
2257 :    
2258 :     if (@$missing > 0)
2259 :     {
2260 : olson 1.16 my $colhdr = ["Assign", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"];
2261 : olson 1.15 my $tbl = [];
2262 :    
2263 :     for my $hit (@$missing)
2264 :     {
2265 :     my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit;
2266 : olson 1.16
2267 :     my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1);
2268 :     my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0);
2269 :    
2270 :     my $checkbox = $cgi->checkbox(-name => "checked",
2271 :     -value => "to=$my_peg,from=$match_peg",
2272 :     -label => "");
2273 :    
2274 :     push(@$tbl, [$checkbox,
2275 :     $psc,
2276 :     $my_peg_link, $my_len, $my_fn,
2277 :     $match_peg_link, $match_len, $match_fn]);
2278 : olson 1.15 }
2279 :    
2280 :     push(@$html, &HTML::make_table($colhdr, $tbl, ""));
2281 :     }
2282 :     else
2283 :     {
2284 :     push(@$html, $cgi->p("No matches."));
2285 : overbeek 1.1 }
2286 : olson 1.15
2287 : overbeek 1.1 }
2288 : olson 1.16 push(@$html,
2289 :     $cgi->submit(-value => "Process assignments",
2290 :     -name => "batch_assign"),
2291 :     $cgi->end_form);
2292 : overbeek 1.1 }
2293 :    
2294 :     sub format_dups {
2295 :     my($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
2296 :     my($i,$j,$duplicates,$user,$role,$org,$link,$genus_species,$abr,$func,$peg);
2297 :    
2298 :     my $subsetC = $subsetsC->{$active_subsetC};
2299 :     my $subsetR = $subsetsR->{$active_subsetR};
2300 :    
2301 :     push(@$html,$cgi->h1('To Check Duplicates:'));
2302 :    
2303 :     for ($i=0; ($i < @$rows); $i++)
2304 :     {
2305 :     $org = $genomes->[$i];
2306 :     next if (! $subsetR->{$org});
2307 :    
2308 :     $duplicates = [];
2309 :     for ($j=1; ($j < @$roles); $j++)
2310 :     {
2311 :     if (($rows->[$i]->[$j] =~ /,/) && $subsetC->{$j})
2312 :     {
2313 :     $user = $cgi->param('user');
2314 :     $role = $roles->[$j];
2315 :     if ($role =~ /^(.*)\t(.*)$/)
2316 :     {
2317 :     ($abr,$role) = ($1,$2);
2318 :     }
2319 :     else
2320 :     {
2321 :     $abr = "";
2322 :     }
2323 :     push(@$duplicates,"$role<br>" . $cgi->ul($cgi->li([map { $peg = "fig|$org.peg.$_"; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } split(/,/,$rows->[$i]->[$j])])));
2324 :     }
2325 :     }
2326 :     if (@$duplicates > 0)
2327 :     {
2328 :     $genus_species = &ext_genus_species($fig,$org);
2329 :     push(@$html,$cgi->h2("$org: $genus_species"));
2330 :     push(@$html,$cgi->ul($cgi->li($duplicates)));
2331 :     }
2332 :     }
2333 :     }
2334 :    
2335 :     sub format_excluded {
2336 :     my($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
2337 :     my($i,$j,$show,$user,$role,$org,$link,$genus_species,$abr,$func,$peg,@excluded,@in,%in);
2338 :    
2339 :     my $subsetC = $subsetsC->{$active_subsetC};
2340 :     my $subsetR = $subsetsR->{$active_subsetR};
2341 :    
2342 :     push(@$html,$cgi->h1('To PEGs with Role, but not in Spreadsheet:'));
2343 :    
2344 :     for ($i=0; ($i < @$rows); $i++)
2345 :     {
2346 :     $org = $genomes->[$i];
2347 :     next if (! $subsetR->{$org});
2348 :    
2349 :     $show = [];
2350 :     for ($j=1; ($j < @$roles); $j++)
2351 :     {
2352 :     next if (! $subsetC->{$j});
2353 :    
2354 :     if ($rows->[$i]->[$j])
2355 :     {
2356 :     @in = map { "fig|$org.peg.$_" } split(/,/,$rows->[$i]->[$j]);
2357 :     }
2358 :     else
2359 :     {
2360 :     @in = ();
2361 :     }
2362 :     %in = map { $_ => 1 } @in;
2363 :     $user = $cgi->param('user');
2364 :     $role = $roles->[$j];
2365 :     if ($role =~ /^(.*)\t(.*)$/)
2366 :     {
2367 :     ($abr,$role) = ($1,$2);
2368 :     }
2369 :     else
2370 :     {
2371 :     $abr = "";
2372 :     }
2373 :     @excluded = grep { ! $in{$_} } &seqs_with_role_precisely($fig,$j,$org,$roles);
2374 :     if (@excluded > 0)
2375 :     {
2376 :     push(@$show,"$role<br>" . $cgi->ul($cgi->li([map { $peg = $_; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } @excluded])));
2377 :     }
2378 :     }
2379 :     if (@$show > 0)
2380 :     {
2381 :     $genus_species = &ext_genus_species($fig,$org);
2382 :     push(@$html,$cgi->h2("$org: $genus_species"));
2383 :     push(@$html,$cgi->ul($cgi->li($show)));
2384 :     }
2385 :     }
2386 :     }
2387 :    
2388 :     sub format_coupled {
2389 :     my($fig,$cgi,$html,$genomes,$roles,$rows,$type,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
2390 :     my($i,$j,@show,$user,$org,$link,$gs,$func,$peg,$peg1,$peg2,%in,%seen,%seen2);
2391 :     my(@cluster,$sc,$x,$id2,@in,$sim,@coupled);
2392 :    
2393 :     my $subsetC = $subsetsC->{$active_subsetC};
2394 :     my $subsetR = $subsetsR->{$active_subsetR};
2395 :    
2396 :     for ($i=0; ($i < @$rows); $i++)
2397 :     {
2398 :     $org = $genomes->[$i];
2399 :     next if (! $subsetR->{$org});
2400 :    
2401 :     for ($j=1; ($j < @$roles); $j++)
2402 :     {
2403 :     if ($rows->[$i]->[$j] && $subsetC->{$j})
2404 :     {
2405 :     push(@in,map { "fig|$org.peg.$_" } split(/,/,$rows->[$i]->[$j]));
2406 :     }
2407 :     }
2408 :     }
2409 :    
2410 :     %in = map { $_ => 1 } @in;
2411 :     $user = $cgi->param('user');
2412 :     @show = ();
2413 :     foreach $peg1 (@in)
2414 :     {
2415 :     if ($type eq "careful")
2416 :     {
2417 :     @coupled = $fig->coupling_and_evidence($peg1,5000,1.0e-10,0.2,1);
2418 :     }
2419 :     else
2420 :     {
2421 :     @coupled = $fig->fast_coupling($peg1,5000,1);
2422 :     }
2423 :    
2424 :     foreach $x (@coupled)
2425 :     {
2426 :     ($sc,$peg2) = @$x;
2427 :     if ((! $in{$peg2}) && ((! $seen{$peg2}) || ($seen{$peg2} < $sc)))
2428 :     {
2429 :     $seen{$peg2} = $sc;
2430 :     # print STDERR "$sc\t$peg1 -> $peg2\n";
2431 :     }
2432 :     }
2433 :     }
2434 :    
2435 :     foreach $peg1 (sort { $seen{$b} <=> $seen{$a} } keys(%seen))
2436 :     {
2437 :     if (! $seen2{$peg1})
2438 :     {
2439 :     @cluster = ($peg1);
2440 :     $seen2{$peg1} = 1;
2441 :     for ($i=0; ($i < @cluster); $i++)
2442 :     {
2443 :     foreach $sim ($fig->sims($cluster[$i],1000,1.0e-10,"fig"))
2444 :     {
2445 :     $id2 = $sim->id2;
2446 :     if ($seen{$id2} && (! $seen2{$id2}))
2447 :     {
2448 :     push(@cluster,$id2);
2449 :     $seen2{$id2} = 1;
2450 :     }
2451 :     }
2452 :     }
2453 :     push(@show, [scalar @cluster,
2454 :     $cgi->br .
2455 :     $cgi->ul($cgi->li([map { $peg = $_;
2456 :     $sc = $seen{$peg};
2457 :     $func = $fig->function_of($peg,$user);
2458 :     $gs = $fig->genus_species($fig->genome_of($peg));
2459 :     $link = &HTML::fid_link($cgi,$peg);
2460 :     "$sc: $link: $func \[$gs\]" }
2461 :     sort { $seen{$b} <=> $seen{$a} }
2462 :     @cluster]))
2463 :     ]);
2464 :     }
2465 :     }
2466 :    
2467 :     if (@show > 0)
2468 :     {
2469 :     @show = map { $_->[1] } sort { $b->[0] <=> $a->[0] } @show;
2470 :     push(@$html,$cgi->h1('Coupled, but not in Spreadsheet:'));
2471 :     push(@$html,$cgi->ul($cgi->li(\@show)));
2472 :     }
2473 :     }
2474 :    
2475 :     sub ext_genus_species {
2476 :     my($fig,$genome) = @_;
2477 :    
2478 :     my $gs = $fig->genus_species($genome);
2479 :     my $c = substr($fig->taxonomy_of($genome),0,1);
2480 :     return "$gs [$c]";
2481 :     }
2482 :    
2483 :     sub show_tree {
2484 :    
2485 :     my($id,$gs);
2486 :     my($tree,$ids) = $fig->build_tree_of_complete;
2487 :     my $relabel = {};
2488 :     foreach $id (@$ids)
2489 :     {
2490 :     if ($gs = $fig->genus_species($id))
2491 :     {
2492 :     $relabel->{$id} = "$gs ($id)";
2493 :     }
2494 :     }
2495 :     $_ = &display_tree($tree,$relabel);
2496 :     print $cgi->pre($_),"\n";
2497 :     }
2498 :    
2499 : olson 1.10 sub export_align_input
2500 :     {
2501 :    
2502 :     }
2503 :    
2504 : overbeek 1.1 sub align_column {
2505 :     my($fig,$cgi,$html,$col,$roles,$genomes,$rows,$subsetsR,$active_subsetR) = @_;
2506 :     my($colN,@checked,$cutoff);
2507 :    
2508 :     my $subsetR = $subsetsR->{$active_subsetR};
2509 :    
2510 : olson 1.10 my $checked;
2511 :    
2512 : overbeek 1.1 if (($colN = &which_column($col,$roles)) &&
2513 :     ((@checked = &seqs_to_align($colN,$genomes,$rows,$subsetR)) > 1))
2514 :     {
2515 :     if ($cutoff = $cgi->param('include_homo'))
2516 :     {
2517 :     my $max = $cgi->param('max_homo');
2518 :     $max = $max ? $max : 100;
2519 :     push(@checked,&get_homologs($fig,\@checked,$cutoff,$max));
2520 :     }
2521 : olson 1.10 $checked = join("\' \'",@checked);
2522 :     }
2523 :     else
2524 :     {
2525 :     push(@$html,"<h1>You need to check at least two sequences</h1>\n");
2526 :     return;
2527 :     }
2528 :    
2529 :    
2530 :     #
2531 :     # See if we want to produce the alignment, or just produce the
2532 :     # input to the alignment.
2533 :     #
2534 :    
2535 :     if ($cgi->param("show_align_input"))
2536 :     {
2537 :     push(@$html, "<pre>\n");
2538 :     my $relabel;
2539 :     foreach my $id (@checked)
2540 :     {
2541 :     my $seq;
2542 :     if ($seq = $fig->get_translation($id))
2543 :     {
2544 :     push(@$html, ">$id\n$seq\n");
2545 :     my $func = $fig->function_of($id);
2546 :     $relabel->{$id} = "$id: $func";
2547 :     }
2548 :     else
2549 :     {
2550 :     push(@$html, "could not find translation for $id\n");
2551 :     }
2552 :     }
2553 :     push(@$html, "\n</pre>\n");
2554 :     }
2555 :     else
2556 :     {
2557 : overbeek 1.1 push(@$html,"<pre>\n");
2558 :     my %org = map { ( $_, $fig->org_of($_) ) } @checked;
2559 :     # Modified by GJO to compress tree and add organism names to tree:
2560 : gdpusch 1.34 # push(@$html,`$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'`);
2561 : overbeek 1.1
2562 :     # Simpler version
2563 :     # push @$html, map { chomp;
2564 :     # /^ *\|[ |]*$/ # line that adds only tree height
2565 :     # ? () # remove it
2566 :     # : /- ([a-z]+\|\S+):/ && defined( $org{$1} ) # tree id?
2567 :     # ? "$_ [$org{$1}]\n" # add the name
2568 :     # : "$_\n" # otherwise leave unmodified
2569 : gdpusch 1.34 # } `$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'`;
2570 : overbeek 1.1
2571 :     # More complex version the preserves double spaced tree tips
2572 :     my $tip = 0;
2573 :     my @out = ();
2574 : overbeek 1.9
2575 : gdpusch 1.34 foreach ( `$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'` )
2576 : overbeek 1.1 {
2577 :     chomp;
2578 :     if ( /^ *\|[ |]*$/ ) {} # line that adds only tree height
2579 :     elsif ( /- ([a-z]+\|\S+):/ ) # line with tree tip
2580 :     {
2581 :     if ( defined( $org{$1} ) ) { $_ .= " [$org{$1}]" } # add org
2582 :     if ( $tip ) { push @out, " |\n" } # 2 tips in a row? add line
2583 :     push @out, "$_\n"; # output current line
2584 :     $tip = 1;
2585 :     }
2586 :     else # not a tip
2587 :     {
2588 :     push @out, "$_\n";
2589 :     $tip = 0;
2590 :     }
2591 :     }
2592 :     push(@$html,&set_links($cgi,\@out));
2593 :     push(@$html,"</pre>\n");
2594 :     }
2595 :     }
2596 :    
2597 :     sub which_column {
2598 :     my($col,$roles) = @_;
2599 :     my($i);
2600 :    
2601 :     if (($col =~ /^(\d+)/) && ($1 <= @$roles))
2602 :     {
2603 :     return $1;
2604 :     }
2605 :     else
2606 :     {
2607 :     for ($i=1; ($i < @$roles) && ($roles->[$i] !~ /^$col\t/); $i++) {}
2608 :     return ($i < @$roles) ? $i : undef;
2609 :     }
2610 :     }
2611 :    
2612 :     sub seqs_to_align {
2613 :     my($colN,$genomes,$rows,$subsetR) = @_;
2614 :     my($i);
2615 :    
2616 :     my @seqs = ();
2617 :     for ($i=0; ($i < @$rows); $i++)
2618 :     {
2619 :     my $genome = $genomes->[$i];
2620 :     if ($subsetR->{$genome})
2621 :     {
2622 :     push(@seqs,map { "fig|$genome.peg.$_" } split(/,/,$rows->[$i]->[$colN]));
2623 :     }
2624 :     }
2625 :     return @seqs;
2626 :     }
2627 :    
2628 :     sub get_homologs {
2629 :     my($fig,$checked,$cutoff,$max) = @_;
2630 :     my($peg,$sim,$id2);
2631 :    
2632 :     my @homologs = ();
2633 :     my %got = map { $_ => 1 } @$checked;
2634 :    
2635 :     foreach $peg (@$checked)
2636 :     {
2637 :     foreach $sim ($fig->sims($peg,$max,$cutoff,"fig"))
2638 :     {
2639 :     $id2 = $sim->id2;
2640 :     if (! $got{$id2})
2641 :     {
2642 :     push(@homologs,[$sim->psc,$id2]);
2643 :     $got{$id2} = 1;
2644 :     }
2645 :     }
2646 :     }
2647 :     @homologs = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @homologs;
2648 :     if (@homologs > $max) { $#homologs = $max-1 }
2649 :    
2650 :     return @homologs;
2651 :     }
2652 :    
2653 :     sub set_links {
2654 :     my($cgi,$out) = @_;
2655 :    
2656 :     my @with_links = ();
2657 :     foreach $_ (@$out)
2658 :     {
2659 :     if ($_ =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
2660 :     {
2661 :     my($before,$peg,$after) = ($1,$2,$3);
2662 :     push(@with_links, $before . &HTML::fid_link($cgi,$peg) . $after . "\n");
2663 :     }
2664 :     else
2665 :     {
2666 :     push(@with_links,$_);
2667 :     }
2668 :     }
2669 :     return @with_links;
2670 :     }
2671 :    
2672 :     sub backup {
2673 :     my($ssaD) = @_;
2674 :    
2675 :     my $sz1 = &size("$ssaD/spreadsheet") + &size("$ssaD/notes");
2676 :     my $sz2 = &size("$ssaD/spreadsheet~") + &size("$ssaD/notes~");
2677 :     if (abs($sz1-$sz2) > 10)
2678 :     {
2679 :     &make_backup($ssaD);
2680 :     }
2681 :     }
2682 :    
2683 :     sub make_backup {
2684 :     my($ssaD) = @_;
2685 :    
2686 :     &FIG::verify_dir("$ssaD/Backup");
2687 :     my $ts = time;
2688 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
2689 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
2690 :     &incr_version($ssaD);
2691 :     }
2692 :    
2693 :     sub incr_version {
2694 :     my($dir) = @_;
2695 :     my($ver);
2696 :    
2697 :     if (open(VER,"<$dir/VERSION"))
2698 :     {
2699 :     if (defined($ver = <VER>) && ($ver =~ /^(\S+)/))
2700 :     {
2701 :     $ver = $1;
2702 :     }
2703 :     else
2704 :     {
2705 :     $ver = 0;
2706 :     }
2707 :     close(VER);
2708 :     }
2709 :     else
2710 :     {
2711 :     $ver = 0;
2712 :     }
2713 :     open(VER,">$dir/VERSION") || die "could not open $dir/VERSION";
2714 :     chmod(0777,"$dir/VERSION");
2715 :     $ver++;
2716 :     print VER "$ver\n";
2717 :     }
2718 :    
2719 :    
2720 :     sub size {
2721 :     my($file) = @_;
2722 :    
2723 :     return (-s $file) ? -s $file : 0;
2724 :     }
2725 :    
2726 :     sub reset_ssa {
2727 :     my($fig,$cgi,$html) = @_;
2728 :     my($ssa,@spreadsheets,$col_hdrs,$tab,$t,$readable,$url,$link,@tmp);
2729 :    
2730 :     if (($ssa = $cgi->param('ssa_name')) && opendir(BACKUP,"$FIG_Config::data/Subsystems/$ssa/Backup"))
2731 :     {
2732 :     @spreadsheets = sort { $b <=> $a }
2733 :     map { $_ =~ /^spreadsheet.(\d+)/; $1 }
2734 :     grep { $_ =~ /^spreadsheet/ }
2735 :     readdir(BACKUP);
2736 :     closedir(BACKUP);
2737 :     $col_hdrs = ["When","Number Genomes"];
2738 :     $tab = [];
2739 :     foreach $t (@spreadsheets)
2740 :     {
2741 :     $readable = &FIG::epoch_to_readable($t);
2742 : overbeek 1.2 $url = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=reset_to&ts=$t";
2743 : overbeek 1.1 $link = "<a href=$url>$readable</a>";
2744 :     open(TMP,"<$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t")
2745 :     || die "could not open $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t";
2746 :     $/ = "//\n";
2747 :     $_ = <TMP>;
2748 :     $_ = <TMP>;
2749 :     $_ = <TMP>;
2750 :     chomp;
2751 :     $/ = "\n";
2752 :    
2753 :     @tmp = grep { $_ =~ /^\d+\.\d+/ } split(/\n/,$_);
2754 :     push(@$tab,[$link,scalar @tmp]);
2755 :     }
2756 :     }
2757 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Possible Points to Reset From"));
2758 :     }
2759 :    
2760 :     sub reset_ssa_to {
2761 :     my($fig,$cgi,$html) = @_;
2762 :     my($ts,$ssa);
2763 :    
2764 :     if (($ssa = $cgi->param('ssa_name')) &&
2765 :     ($ts = $cgi->param('ts')) &&
2766 :     (-s "$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts"))
2767 :     {
2768 :     system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts $FIG_Config::data/Subsystems/$ssa/spreadsheet";
2769 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet");
2770 :     if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts")
2771 :     {
2772 :     system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts $FIG_Config::data/Subsystems/$ssa/notes";
2773 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
2774 :     }
2775 :     push(@$html,$cgi->h1("Reset"));
2776 :     }
2777 :     }
2778 :    
2779 :     sub make_exchangable {
2780 :     my($fig,$cgi,$html) = @_;
2781 :     my($ssa);
2782 :    
2783 :     if (($ssa = $cgi->param('ssa_name')) &&
2784 :     (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet") &&
2785 :     open(TMP,">$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
2786 :     {
2787 :     print TMP "1\n";
2788 :     close(TMP);
2789 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
2790 :     }
2791 :     }
2792 :    
2793 :     sub make_unexchangable {
2794 :     my($fig,$cgi,$html) = @_;
2795 :     my($ssa);
2796 :    
2797 :     if (($ssa = $cgi->param('ssa_name')) &&
2798 :     (-s "$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
2799 :     {
2800 :     unlink("$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
2801 :     }
2802 :     }
2803 :    
2804 :     sub fid_links {
2805 : overbeek 1.36 my($cgi,$entry,$genome,$suff) = @_;
2806 : overbeek 1.1 my($pegN);
2807 :    
2808 :     my @links = ();
2809 :     foreach $pegN (split(/,/,$entry->[0]))
2810 :     {
2811 : overbeek 1.36 push(@links,&HTML::fid_link($cgi,"fig|$genome.peg.$pegN","local") . $suff);
2812 : overbeek 1.1 }
2813 : overbeek 1.36 return @links;
2814 : overbeek 1.1 }
2815 :    
2816 :     sub group_by_clusters {
2817 :     my($fig,$genome,$tmp) = @_;
2818 :     my(@pegs,$entry,$pegN,%pegs,$peg,$peg1,%conn,%seen,@entries);
2819 :     my($i,$x,@cluster,@clusters,%in,$best,$cluster,$which,$colors);
2820 :    
2821 :     if (! $cgi->param('show_clusters'))
2822 :     {
2823 :     return map { [$_,"#FFFFFF"] } @$tmp;
2824 :     }
2825 :    
2826 :     @pegs = ();
2827 :     foreach $entry (@$tmp)
2828 :     {
2829 :     foreach $pegN (split(/,/,$entry))
2830 :     {
2831 :     push(@pegs,"fig|$genome.peg.$pegN");
2832 :     }
2833 :     }
2834 :     %pegs = map { $_ => 1 } @pegs;
2835 : overbeek 1.2 @pegs = keys(%pegs);
2836 : overbeek 1.1
2837 :     foreach $peg (@pegs)
2838 :     {
2839 :     foreach $peg1 (grep { $pegs{$_} && ($_ ne $peg) } $fig->close_genes($peg,5000))
2840 :     {
2841 :     push(@{$conn{$peg}},$peg1);
2842 :     }
2843 :     }
2844 :    
2845 :     @clusters = ();
2846 :     while ($peg = shift @pegs)
2847 :     {
2848 :     if (! $seen{$peg})
2849 :     {
2850 :     @cluster = ($peg);
2851 :     $seen{$peg} = 1;
2852 :     for ($i=0; ($i < @cluster); $i++)
2853 :     {
2854 :     $x = $conn{$cluster[$i]};
2855 :     foreach $peg1 (@$x)
2856 :     {
2857 :     if (! $seen{$peg1})
2858 :     {
2859 :     push(@cluster,$peg1);
2860 :     $seen{$peg1} = 1;
2861 :     }
2862 :     }
2863 :     }
2864 :     push(@clusters,[@cluster]);
2865 :     }
2866 :     }
2867 :    
2868 :     @clusters = sort { @$b <=> @$a } @clusters;
2869 :     for ($i=0; ($i < @clusters); $i++)
2870 :     {
2871 :     $cluster = $clusters[$i];
2872 :     foreach $peg (@$cluster)
2873 :     {
2874 :     $peg =~ /(\d+)$/;
2875 :     $in{$1} = $i;
2876 :     }
2877 :     }
2878 :    
2879 :     $colors =
2880 :     [
2881 :     '#C0C0C0',
2882 :     '#FF40C0',
2883 :     '#FF8040',
2884 :     '#FF0080',
2885 :     '#FFC040',
2886 :     '#40C0FF',
2887 :     '#40FFC0',
2888 :     '#C08080',
2889 :     '#C0FF00',
2890 :     '#00FF80',
2891 :     '#00C040'
2892 :     ];
2893 :    
2894 :     @entries = ();
2895 :     foreach $entry (@$tmp)
2896 :     {
2897 :     $best = undef;
2898 :     foreach $pegN (split(/,/,$entry))
2899 :     {
2900 :     $which = $in{$pegN};
2901 :     if ((! defined($best)) || ($best > $which))
2902 :     {
2903 :     $best = $which;
2904 :     }
2905 :     }
2906 :    
2907 :     if (defined($best) && (@{$clusters[$best]} > 1) && ($best < @$colors))
2908 :     {
2909 :     push(@entries,[$entry,$colors->[$best]]);
2910 :     }
2911 :     else
2912 :     {
2913 :     push(@entries,[$entry,'#FFFFFF']);
2914 :     }
2915 :     }
2916 :     return @entries;
2917 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3