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

Annotation of /FigWebServices/ssa2.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3