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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 :    
3 :     use FIG;
4 :     my $fig = new FIG;
5 :     use Subsystem;
6 :    
7 :     use HTML;
8 :     use strict;
9 :     use tree_utilities;
10 :    
11 :     use CGI;
12 :     my $cgi = new CGI;
13 :    
14 :     if (0)
15 :     {
16 :     my $VAR1;
17 :     eval(join("",`cat /tmp/ssa_parms`));
18 :     $cgi = $VAR1;
19 :     # print STDERR &Dumper($cgi);
20 :     }
21 :    
22 :     if (0)
23 :     {
24 :     print $cgi->header;
25 :     my @params = $cgi->param;
26 :     print "<pre>\n";
27 :     foreach $_ (@params)
28 :     {
29 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
30 :     }
31 :    
32 :     if (0)
33 :     {
34 :     if (open(TMP,">/tmp/ssa_parms"))
35 :     {
36 :     print TMP &Dumper($cgi);
37 :     close(TMP);
38 :     }
39 :     }
40 :     exit;
41 :     }
42 :    
43 :     # request to display the phylogenetic tree
44 :     #
45 :     my $request = $cgi->param("request");
46 :     if ($request && ($request eq "show_tree"))
47 :     {
48 :     print $cgi->header;
49 :     &show_tree;
50 :     exit;
51 :     }
52 :    
53 :     my $html = [];
54 :    
55 :     my $user = $cgi->param('user');
56 :     $fig->set_user($user);
57 :    
58 :     if ((! $user) || ($user !~ /^master:\S+/))
59 :     {
60 :     push(@$html,$cgi->h1("Sorry, you need to specify a master user to modify subsystem annotations"));
61 :     }
62 :     elsif ($cgi->param("extend_with_billogix"))
63 :     {
64 :     #
65 :     # Start a bg task to extend the subsystem.
66 :     #
67 :    
68 :     my $ssa = $cgi->param('ssa_name');
69 :    
70 :     my $user = $cgi->param('user');
71 :    
72 :     my $sub = $fig->get_subsystem($ssa);
73 :    
74 :     if ($sub)
75 :     {
76 :     #
77 :     # See if there's already an extend job running.
78 :     #
79 :    
80 :     my $curpid = $sub->get_current_extend_pid();
81 :     if ($curpid)
82 :     {
83 :     warn "Found current pid $curpid\n";
84 :     my $j = $fig->get_job($curpid);
85 :     warn "job is $j\n";
86 :     warn "running is ", $j->running(), "\n" if $j;
87 :     if ($j && $j->running())
88 :     {
89 :     push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
90 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
91 :     last;
92 :     }
93 :     }
94 :    
95 :     my $pid = $fig->run_in_background(sub {$sub->extend_with_billogix($user);});
96 :    
97 :     push(@$html,
98 :     "Subsystem extension started as background job number $pid <br>\n",
99 :     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
100 :    
101 :     $sub->set_current_extend_pid($pid);
102 :     }
103 :     else
104 :     {
105 :     push(@$html, "Subsystem '$ssa' could not be loaded");
106 :     }
107 :     &HTML::show_page($cgi, $html);
108 :     exit;
109 :     }
110 :     else
111 :     {
112 :     $request = defined($request) ? $request : "";
113 :    
114 :     if ($request eq "reset")
115 :     {
116 :     &reset_ssa($fig,$cgi,$html); # allow user to go back to a previous version of the ss
117 :     }
118 :     elsif ($request eq "reset_to")
119 :     {
120 :     &reset_ssa_to($fig,$cgi,$html); # this actually resets to the previous version
121 :     &show_ssa($fig,$cgi,$html);
122 :     }
123 :     elsif ($request eq "make_exchangable")
124 :     {
125 :     &make_exchangable($fig,$cgi,$html);
126 :     &show_initial($fig,$cgi,$html);
127 :     }
128 :     elsif ($request eq "make_unexchangable")
129 :     {
130 :     &make_unexchangable($fig,$cgi,$html);
131 :     &show_initial($fig,$cgi,$html);
132 :     }
133 :     elsif ($request eq "show_ssa")
134 :     {
135 :     &one_cycle($fig,$cgi,$html);
136 :     }
137 :     #
138 :     # Note that this is a little different; I added another submit button
139 :     # to the delete_or_export_ssa form, so have to distinguish between them
140 :     # here based on $cgi->param('delete_export') - the original button,
141 :     # or $cgi->param('publish') - the new one.
142 :     #
143 :     elsif ($request eq "delete_or_export_ssa" and
144 :     defined($cgi->param('delete_export')))
145 :     {
146 :     my($ssa,$exported);
147 :     $exported = 0;
148 :     foreach $ssa ($cgi->param('export'))
149 :     {
150 :     if (! $exported)
151 :     {
152 :     print $cgi->header;
153 :     print "<pre>\n";
154 :     }
155 :     &export($fig,$cgi,$ssa);
156 :     $exported = 1;
157 :     }
158 :    
159 :     foreach $ssa ($cgi->param('export_assignments'))
160 :     {
161 :     &export_assignments($fig,$cgi,$ssa);
162 :     }
163 :    
164 :     foreach $ssa ($cgi->param('delete'))
165 :     {
166 :     my $sub = $fig->get_subsystem($ssa);
167 :     $sub->delete_indices();
168 :    
169 :     my $cmd = "rm -rf '$FIG_Config::data/Subsystems/$ssa'";
170 :     my $rc = system $cmd;
171 :     }
172 :    
173 :     if (! $exported)
174 :     {
175 :     &show_initial($fig,$cgi,$html);
176 :     }
177 :     else
178 :     {
179 :     print "</pre>\n";
180 :     exit;
181 :     }
182 :     }
183 :     elsif ($request eq "delete_or_export_ssa" and
184 :     defined($cgi->param('publish')))
185 :     {
186 :     my($ssa,$exported);
187 :     my($ch) = $fig->get_clearinghouse();
188 :    
189 :     print $cgi->header;
190 :    
191 :     if (!defined($ch))
192 :     {
193 :     print "cannot publish: clearinghouse not available\n";
194 :     exit;
195 :     }
196 :    
197 :     foreach $ssa ($cgi->param('publish_to_clearinghouse'))
198 :     {
199 :     print "<h2>Publishing $ssa to clearinghouse...</h2>\n";
200 :     $| = 1;
201 :     print "<pre>\n";
202 :     my $res = $fig->publish_subsystem_to_clearinghouse($ssa);
203 :     print "</pre>\n";
204 :     if ($res)
205 :     {
206 :     print "Published <i>$ssa </i> to clearinghouse<br>\n";
207 :     }
208 :     else
209 :     {
210 :     print "<b>Failed</b> to publish <i>$ssa</i> to clearinghouse<br>\n";
211 :     }
212 :     }
213 :     exit;
214 :     }
215 :     elsif (($request eq "new_ssa") && ($cgi->param('copy_from1')) && (! $cgi->param('cols_to_take1')))
216 :     {
217 :     my $user = $cgi->param('user');
218 :     my $name = $cgi->param('ssa_name');
219 :     my $copy_from1 = $cgi->param('copy_from1');
220 :     my $copy_from2 = $cgi->param('copy_from2');
221 :     my(@roles1,@roles2);
222 :    
223 :     push(@$html,$cgi->start_form(-action => "subsys.cgi",
224 :     -method => 'post'),
225 :     $cgi->hidden(-name => 'copy_from1', -value => $copy_from1, -override => 1),
226 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
227 :     $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
228 :     $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1)
229 :     );
230 :    
231 :     @roles1 = $fig->subsystem_to_roles($copy_from1);
232 :     if (@roles1 > 0)
233 :     {
234 :     push(@$html,$cgi->h1("select columns to be taken from $copy_from1"),
235 :     $cgi->scrolling_list(-name => 'cols_to_take1',
236 :     -values => ['all',@roles1],
237 :     -size => 10,
238 :     -multiple => 1
239 :     ),
240 :     $cgi->hr
241 :     );
242 :     }
243 :    
244 :     if ($copy_from2)
245 :     {
246 :     @roles2 = $fig->subsystem_to_roles($copy_from2);
247 :     if (@roles2 > 0)
248 :     {
249 :     push(@$html,$cgi->hidden(-name => 'copy_from2', -value => $copy_from2, -override => 1));
250 :     push(@$html,$cgi->h1("select columns to be taken from $copy_from2"),
251 :     $cgi->scrolling_list(-name => 'cols_to_take2',
252 :     -values => ['all',@roles2],
253 :     -size => 10,
254 :     -multiple => 1
255 :     ),
256 :     $cgi->hr
257 :     );
258 :     }
259 :     }
260 :     push(@$html,$cgi->submit('build new subsystem'),
261 :     $cgi->end_form
262 :     );
263 :     }
264 :     elsif ($request eq "new_ssa")
265 :     {
266 :     &new_ssa($fig,$cgi,$html);
267 :     }
268 :     else
269 :     {
270 :     &show_initial($fig,$cgi,$html);
271 :     }
272 :     }
273 :    
274 :     &HTML::show_page($cgi,$html);
275 :    
276 :    
277 :     sub show_initial {
278 :     my($fig,$cgi,$html) = @_;
279 :     my($set,$when,$comment);
280 :    
281 :     my $user = $cgi->param('user');
282 :     my @ssa = &existing_subsystem_annotations;
283 :    
284 :     if (@ssa > 0)
285 :     {
286 :     &format_ssa_table($cgi,$html,$user,\@ssa);
287 :     }
288 :    
289 :     my $target = "window$$";
290 :     push(@$html, $cgi->h1('To Start or Copy a Subsystem'),
291 :     $cgi->start_form(-action => "subsys.cgi",
292 :     -target => $target,
293 :     -method => 'post'),
294 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
295 :     $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1),
296 :     "Name of New Subsystem: ",
297 :     $cgi->textfield(-name => "ssa_name", -size => 50),
298 :     $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1),
299 :     $cgi->br,
300 :    
301 :     "Copy from (leave blank to start from scratch): ",
302 :     $cgi->textfield(-name => "copy_from1", -size => 50),
303 :     $cgi->br,
304 :    
305 :     "Copy from (leave blank to start from scratch): ",
306 :     $cgi->textfield(-name => "copy_from2", -size => 50),
307 :     $cgi->br,
308 :    
309 :     $cgi->submit('start new subsystem'),
310 :     $cgi->end_form,
311 :     "<br>You can start a subsystem from scratch, in which case you should leave these two \"copy from\"
312 :     fields blank. If you wish to just copy a subsystem (in order to become the owner so that you can modify it),
313 :     just fill in one of the \"copy from\" fields with the name of the subsystem you wish to copy. If you wish to
314 :     extract a a subset of the columns to build a smaller spreadsheet (which could later be merged with another one),
315 :     fill in the name of the subsystem. You will be prompted for the columns that you wish to extract (choose <i>all</i> to
316 :     just copy all of the columns). Finally, if you wish to build a new spreadsheet by including columns from two existing
317 :     spreadsheets (including a complete merger), fill in the names of both the existing \"copy from\" subsystems"
318 :     );
319 :     }
320 :    
321 :     sub new_ssa {
322 :     my($fig,$cgi,$html) = @_;
323 :    
324 :     my $user = $cgi->param('user');
325 :     my $name = $cgi->param('ssa_name');
326 :    
327 :     if (! $user)
328 :     {
329 :     push(@$html,$cgi->h1('You need to specify a user before starting a new subsystem annotation'));
330 :     return;
331 :     }
332 :    
333 :     if (! $name)
334 :     {
335 :     push(@$html,$cgi->h1('You need to specify a subsystem name'));
336 :     return;
337 :     }
338 :    
339 :     my $ssa = $name;
340 :     $ssa =~ s/[ \/]/_/g;
341 :    
342 :     &FIG::verify_dir("$FIG_Config::data/Subsystems");
343 :    
344 :     if (-d "$FIG_Config::data/Subsystems/$ssa")
345 :     {
346 :     push(@$html,$cgi->h1("You need to specify a new subsystem name; $ssa already is being used"));
347 :     return;
348 :     }
349 :    
350 :     my $subsystem = new Subsystem($ssa,$fig,1); # create new subsystem
351 :    
352 :     my $copy_from1 = $cgi->param('copy_from1');
353 :     $copy_from1 =~ s/[ \/]/_/g;
354 :     my $copy_from2 = $cgi->param('copy_from2');
355 :     $copy_from2 =~ s/[ \/]/_/g;
356 :     my @cols_to_take1 = $cgi->param('cols_to_take1');
357 :     my @cols_to_take2 = $cgi->param('cols_to_take2');
358 :    
359 :    
360 :     if ($copy_from1 && (@cols_to_take1 > 0))
361 :     {
362 :     $subsystem->add_to_subsys($copy_from1,\@cols_to_take1,"take notes"); # add columns and notes
363 :     }
364 :    
365 :     if ($copy_from2 && (@cols_to_take2 > 0))
366 :     {
367 :     $subsystem->add_to_subsys($copy_from2,\@cols_to_take2,"take notes"); # add columns and notes
368 :     }
369 :    
370 :     $subsystem->write_subsystem();
371 :    
372 :     $cgi->param(-name => "can_alter",
373 :     -value => 1);
374 :     &one_cycle($fig,$cgi,$html);
375 :     }
376 :    
377 :     # The basic update logic (cycle) includes the following steps:
378 :     #
379 :     # 1. Load the existing spreadsheet
380 :     # 2. reconcile row and subset changes
381 :     # 3. process spreadsheet changes (fill/refill/add genomes)
382 :     # 4. write the updated spreadsheet back to disk
383 :     # 5. render the spreadsheet
384 :     #
385 :     sub one_cycle {
386 :     my($fig,$cgi,$html) = @_;
387 :    
388 :     my $user = $cgi->param('user');
389 :     my $ssa = $cgi->param('ssa_name');
390 :    
391 :    
392 :     if (! $user)
393 :     {
394 :     push(@$html,$cgi->h1('You need to specify a user to work on a subsystem annotation'));
395 :     return;
396 :     }
397 :    
398 :     if (! $ssa)
399 :     {
400 :     push(@$html,$cgi->h1('You need to specify a subsystem'));
401 :     return;
402 :     }
403 :    
404 :     my $subsystem = new Subsystem($ssa,$fig,0);
405 :     if (&handle_role_and_subset_changes($fig,$subsystem,$cgi,$html))
406 :     {
407 :     &process_spreadsheet_changes($fig,$subsystem,$cgi,$html);
408 :     $subsystem->write_subsystem();
409 :     &produce_html_to_display_subsystem($fig,$subsystem,$cgi,$html);
410 :     }
411 :     }
412 :    
413 :     sub handle_role_and_subset_changes {
414 :     my($fig,$subsystem,$cgi,$html) = @_;
415 :    
416 :     if (! $cgi->param('can_alter'))
417 :     {
418 :     return 1; # no changes, so...
419 :     }
420 :     else
421 :     {
422 :     my($role,$p,$abr,$r,$n);
423 :     my @tuplesR = ();
424 :     my @roles = grep { $_ =~ /^role/ } $cgi->param();
425 :     if (@roles == 0) { return 1 } # initial call, everything is as it was
426 :    
427 :     foreach $role (@roles)
428 :     {
429 :     if (($role =~ /^role(\d+)/) && defined($n = $1))
430 :     {
431 :     if ($r = $cgi->param("role$n"))
432 :     {
433 :     if (($p = $cgi->param("posR$n")) && ($abr = $cgi->param("abbrev$n")))
434 :     {
435 :     push(@tuplesR,[$p,$r,$abr]);
436 :     }
437 :     else
438 :     {
439 :     push(@$html,$cgi->h1("You need to give a position and abbreviation for $r"));
440 :     return 0;
441 :     }
442 :     }
443 :     }
444 :     }
445 :     $subsystem->set_roles([map { [$_->[1],$_->[2]] } sort { $a->[0] <=> $b->[0] } @tuplesR]);
446 :    
447 :     my($subset_name,$s,$test,@entries,$entry);
448 :     my @subset_names = grep { $_ =~ /^subset_name/ } $cgi->param();
449 :     foreach $subset_name (@subset_names)
450 :     {
451 :     if (($subset_name =~ /^subset_name(\d+)/) && defined($n = $1) && ($s = $cgi->param("nameCS$n")))
452 :     {
453 :     my($text);
454 :     if ($text = $cgi->param("subset$n"))
455 :     {
456 :     @entries = ();
457 :     foreach $entry (split(/[\s,]+/,$text))
458 :     {
459 :     if ($role = &to_role($entry,\@tuplesR))
460 :     {
461 :     push(@entries,$role);
462 :     }
463 :     else
464 :     {
465 :     push(@$html,$cgi->h1("Invalid role designation in subset $s: $entry"));
466 :     return 0;
467 :     }
468 :     }
469 :     $subsystem->set_subset($s,\@entries);
470 :     }
471 :     }
472 :     }
473 :     }
474 :     return 1;
475 :     }
476 :    
477 :     sub to_role {
478 :     my($x,$role_tuples) = @_;
479 :     my $i;
480 :    
481 :     for ($i=0; ($i < @$role_tuples) &&
482 :     ($role_tuples->[0] != $x) &&
483 :     ($role_tuples->[1] != $x) &&
484 :     ($role_tuples->[2] != $x); $i++) {}
485 :     if ($i < @$role_tuples)
486 :     {
487 :     return $role_tuples->[$i]->[1];
488 :     }
489 :     return undef;
490 :     }
491 :    
492 :     sub process_spreadsheet_changes {
493 :     my($fig,$subsystem,$cgi,$html) = @_;
494 :    
495 :     if (! $cgi->param('can_alter'))
496 :     {
497 :     return 1; # no changes, so...
498 :     }
499 :     else
500 :     {
501 :     if ($cgi->param('refill'))
502 :     {
503 :     &refill_spreadsheet($fig,$subsystem);
504 :     }
505 :     elsif ($cgi->param('precise_fill'))
506 :     {
507 :     &fill_empty_cells($fig,$subsystem);
508 :     }
509 :    
510 :     my @orgs = $cgi->param('new_genome');
511 :     @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
512 :    
513 :     my $org;
514 :     foreach $org (@orgs)
515 :     {
516 :     &add_genome($fig,$subsystem,$cgi,$html,$org);
517 :     }
518 :     }
519 :     }
520 :    
521 :     sub refill_spreadsheet {
522 :     my($fig,$subsystem) = @_;
523 :     my($genome,$role,@pegs);
524 :    
525 :     foreach $genome ($subsystem->get_genomes())
526 :     {
527 :     foreach $role ($subsystem->get_roles())
528 :     {
529 :     @pegs = $fig->seqs_with_role($role,"master",$genome);
530 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
531 :     }
532 :     }
533 :     }
534 :    
535 :     sub fill_empty_cells {
536 :     my($fig,$subsystem) = @_;
537 :     my($genome,$role,@pegs);
538 :    
539 :     foreach $genome ($subsystem->get_genomes())
540 :     {
541 :     foreach $role ($subsystem->get_roles())
542 :     {
543 :     @pegs = $subsystem->get_pegs_from_cell($genome,$role);
544 :     if (@pegs == 0)
545 :     {
546 :     @pegs = $fig->seqs_with_role($role,"master",$genome);
547 :     if (@pegs > 0)
548 :     {
549 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
550 :     }
551 :     }
552 :     }
553 :     }
554 :     }
555 :    
556 :     sub add_genome {
557 :     my($fig,$subsystem,$cgi,$html,$genome) = @_;
558 :     my($role,@pegs);
559 :    
560 :     $subsystem->add_genome($genome);
561 :     foreach $role ($subsystem->get_roles())
562 :     {
563 :     @pegs = $fig->seqs_with_role($role,"master",$genome);
564 :     $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
565 :     }
566 :     }
567 :    
568 :     sub produce_html_to_display_subsystem {
569 :     my($fig,$subsystem,$cgi,$html) = @_;
570 :    
571 :     my $user = $cgi->param('user');
572 :     my $ssa = $cgi->param('ssa_name');
573 :     my $can_alter = $cgi->param('can_alter');
574 :    
575 :     my $name = $ssa;
576 :     $name =~ s/_/ /g;
577 :     $ssa =~ s/[ \/]/_/g;
578 :    
579 :     push(@$html, $cgi->h1("Subsystem: $name"),
580 :     $cgi->start_form(-action => "subsys.cgi",
581 :     -method => 'post'),
582 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
583 :     $cgi->hidden(-name => 'request', -value => 'show_ssa', -override => 1),
584 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
585 :     $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
586 :     $cgi->br,
587 :     );
588 :    
589 :     &format_roles($fig,$cgi,$html,$subsystem);
590 :     &format_subsets($fig,$cgi,$html,$subsystem);
591 :     &format_rows($fig,$cgi,$html,$subsystem);
592 :    
593 :     if ($can_alter)
594 :     {
595 :     &format_extend_with($fig,$cgi,$html,$subsystem);
596 :     push(@$html,$cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill'),$cgi->br);
597 :     push(@$html,$cgi->br);
598 :     push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
599 :     }
600 :     else
601 :     {
602 :     push(@$html,$cgi->br);
603 :     push(@$html,$cgi->submit('show spreadsheet'),$cgi->br);
604 :    
605 :     }
606 :    
607 :     push(@$html, $cgi->a({href => "ss_export.cgi?user=$user&ssa_name=$ssa"},
608 :     "Export subsystem data"),
609 :     $cgi->br);
610 :    
611 :     push(@$html,$cgi->checkbox(-name => 'ignore_alt', -value => 1, -checked => 0, -override => 1,-label => 'ignore alternatives'),$cgi->br);
612 :     push(@$html,$cgi->checkbox(-name => 'show_clusters', -value => 1, -checked => 0, -override => 1,-label => 'show clusters'),$cgi->br);
613 :     push(@$html,$cgi->checkbox(-name => 'show_missing', -value => 1, -checked => 0, -override => 1,-label => 'show missing'),$cgi->br);
614 :     push(@$html,$cgi->checkbox(-name => 'show_missing_including_matches', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches'),
615 :     "&nbsp; &nbsp; [To restrict to a single genome: ",
616 :     $cgi->textfield(-name => "just_genome", -size => 15),"]",
617 :     "&nbsp; &nbsp; [To restrict to a single role: ",
618 :     $cgi->textfield(-name => "just_role", -size => 15),"]",
619 :     $cgi->br
620 :     );
621 :     push(@$html,$cgi->checkbox(-name => 'refill', -value => 1, -checked => 0, -override => 1,-label => 'refill spreadsheet from scratch'),$cgi->br);
622 :     push(@$html,$cgi->checkbox(-name => 'show_dups', -value => 1, -checked => 0, -override => 1,-label => 'show duplicates'),$cgi->br);
623 :     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);
624 :     push(@$html,$cgi->checkbox(-name => 'add_solid', -value => 1, -checked => 0, -override => 1,-label => 'Add Genomes with Solid Hits'),$cgi->br);
625 :     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);
626 :     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);
627 :     push(@$html,$cgi->br,"Align column: ",
628 :     $cgi->textfield(-name => "col_to_align", -size => 7),
629 :     $cgi->checkbox(-name => "show_align_input", -checked => 0,
630 :     -label => "show input to alignment tool"),
631 :     $cgi->br,"Include homologs that pass the following threshhold: ",
632 :     $cgi->textfield(-name => "include_homo", -size => 10)," (leave blank to see just column)",
633 :     " Max homologous seqs: ",$cgi->textfield(-name => "max_homo", -value => 100, -size => 6),
634 :     );
635 :    
636 :     if ($can_alter)
637 :     {
638 :     push(@$html,
639 :     $cgi->p,
640 :     $cgi->submit(-value => "Start automated subsystem extension",
641 :     -name => "extend_with_billogix"),
642 :     $cgi->br);
643 :     }
644 :     push(@$html, $cgi->end_form);
645 :    
646 :     push(@$html, $cgi->hr);
647 :    
648 :     if ($cgi->param('show_missing'))
649 :     {
650 :     &format_missing($fig,$cgi,$html,$subsystem);
651 :     }
652 :    
653 :     if ($cgi->param('show_missing_including_matches'))
654 :     {
655 :     &format_missing_including_matches($fig,$cgi,$html,$subsystem);
656 :     }
657 :    
658 :     if ($cgi->param('show_dups'))
659 :     {
660 :     &format_dups($fig,$cgi,$html,$subsystem);
661 :     }
662 :    
663 :     if ($cgi->param('show_coupled'))
664 :     {
665 :     &format_coupled($fig,$cgi,$html,$subsystem,"careful");
666 :     }
667 :     elsif ($cgi->param('show_coupled_fast'))
668 :     {
669 :     &format_coupled($fig,$cgi,$html,$subsystem,"fast");
670 :     }
671 :    
672 :     my $col;
673 :     if ($col = $cgi->param('col_to_align'))
674 :     {
675 :     &align_column($fig,$cgi,$html,$col,$subsystem);
676 :     }
677 :    
678 :     my $notes = $cgi->param('notes');
679 :     if (! $notes)
680 :     {
681 :     $notes = $subsystem->get_notes();
682 :     }
683 :     else
684 :     {
685 :     $subsystem->set_notes($notes);
686 :     }
687 :     push(@$html,$cgi->hr,"NOTES:\n",$cgi->br,$cgi->textarea(-name => 'notes', -rows => 40, -cols => 100, -value => $notes));
688 :     }
689 :    
690 :     sub format_extend_with {
691 :     my($fig,$cgi,$html,$subsystem) = @_;
692 :     my($org,$gs);
693 :    
694 :     my %genomes = map { $_ => 1 } $subsystem->get_genomes();
695 :    
696 :     my @orgs = sort map { $org = $_; $gs = &ext_genus_species($fig,$org); "$gs ($org)" }
697 :     grep { ! $genomes{$_} }
698 :     $fig->genomes("complete",undef);
699 :    
700 :     push(@$html,
701 :     $cgi->h1('Pick Organisms to Extend with'),
702 :     $cgi->scrolling_list(-name => 'new_genome',
703 :     -values => [@orgs],
704 :     -size => 10,
705 :     -multiple => 1
706 :     ),
707 :     $cgi->hr
708 :     );
709 :     }
710 :    
711 :     sub format_roles {
712 :     my($fig,$cgi,$html,$subsystem) = @_;
713 :     my($i);
714 :    
715 :     my $col_hdrs = ["Column","Abbrev","Functional Role"];
716 :     my $tab = [];
717 :    
718 :     my $n = 1;
719 :     &format_existing_roles($fig,$cgi,$html,$subsystem,$tab,\$n);
720 :     if ($cgi->param('can_alter'))
721 :     {
722 :     for ($i=0; ($i < 5); $i++)
723 :     {
724 :     &format_role($fig,$cgi,$html,$subsystem,$tab,$n,"");
725 :     $n++;
726 :     }
727 :     }
728 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Functional Roles"),
729 :     $cgi->hr
730 :     );
731 :     }
732 :    
733 :     sub format_existing_roles {
734 :     my($fig,$cgi,$html,$subsystem,$tab,$nP) = @_;
735 :     my($role);
736 :    
737 :     foreach $role ($subsystem->get_roles)
738 :     {
739 :     &format_role($fig,$cgi,$html,$subsystem,$tab,$$nP,$role);
740 :     $$nP++;
741 :     }
742 :     }
743 :    
744 :     sub format_role {
745 :     my($fig,$cgi,$html,$subsystem,$tab,$n,$role) = @_;
746 :     my($abbrev);
747 :    
748 :     $abbrev = $role ? $subsystem->get_role_abbr($subsystem->get_role_index($role)) : "";
749 :    
750 :     my($posT,$abbrevT,$roleT);
751 :     if ($cgi->param('can_alter'))
752 :     {
753 :     $posT = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1);
754 :     $abbrevT = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1);
755 :     $roleT = $cgi->textfield(-name => "role$n", -size => 80, -value => $role, -override => 1);
756 :     }
757 :     else
758 :     {
759 :     push(@$html,$cgi->hidden(-name => "posR$n", -value => $n, -override => 1),
760 :     $cgi->hidden(-name => "abbrev$n", -value => $abbrev, -override => 1),
761 :     $cgi->hidden(-name => "role$n", -value => $role, -override => 1));
762 :     $posT = $n;
763 :     $abbrevT = $abbrev;
764 :     $roleT = $role;
765 :     }
766 :     #
767 :     # Wrap the first element in the table with a <A NAME="role_rolename"> tag
768 :     # so we can zing to it from elsewhere. We remove any non-alphanumeric
769 :     # chars in the role name.
770 :     #
771 :    
772 :     my $posT_html;
773 :     {
774 :     my $rn = $role;
775 :     $rn =~ s/[ \/]/_/g;
776 :     $rn =~ s/\W//g;
777 :    
778 :     $posT_html = "<a name=\"$rn\">$posT</a>";
779 :     }
780 :    
781 :    
782 :     push(@$tab,[$posT_html,$abbrevT,$roleT]);
783 :    
784 :     if ($cgi->param('check_problems'))
785 :     {
786 :     my @roles = grep { $_->[0] ne $role } &gene_functions_in_col($fig,$role,$subsystem);
787 :     my($x,$peg);
788 :     foreach $x (@roles)
789 :     {
790 :     push(@$tab,["","",$x->[0]]);
791 :     push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]);
792 :     }
793 :     }
794 :     }
795 :    
796 :     sub gene_functions_in_col {
797 :     my($fig,$role,$subsystem) = @_;
798 :     my(%roles,$peg,$func);
799 :    
800 :     # incr by 1 to get col indexed from 1 (not 0)
801 :     my @pegs = map { @$_ } @{$subsystem->get_col($subsystem->get_role_index($role) + 1)};
802 :     foreach $peg (@pegs)
803 :     {
804 :     if ($func = $fig->function_of($peg))
805 :     {
806 :     push(@{$roles{$func}},$peg);
807 :     }
808 :     }
809 :     return map { [$_,$roles{$_}] } sort keys(%roles);
810 :     }
811 :    
812 :     sub format_subsets {
813 :     my($fig,$cgi,$html,$subsystem) = @_;
814 :    
815 :     &format_subsetsC($fig,$cgi,$html,$subsystem);
816 :     &format_subsetsR($fig,$cgi,$html,$subsystem);
817 :     }
818 :    
819 :     sub format_subsetsC {
820 :     my($fig,$cgi,$html,$subsystem) = @_;
821 :    
822 :     my $col_hdrs = ["Subset","Includes These Roles"];
823 :     my $tab = [];
824 :    
825 :     my $n = 1;
826 :     &format_existing_subsetsC($cgi,$html,$subsystem,$tab,\$n);
827 :     if ($cgi->param('can_alter'))
828 :     {
829 :     my $i;
830 :     for ($i=0; ($i < 5); $i++)
831 :     {
832 :     &format_subsetC($cgi,$html,$subsystem,$tab,$n,"");
833 :     $n++;
834 :     }
835 :     }
836 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Subsets of Roles"),
837 :     $cgi->hr
838 :     );
839 :    
840 :     my @subset_names = $subsystem->get_subset_namesC;
841 :     if (@subset_names > 1)
842 :     {
843 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
844 :    
845 :     push(@$html,$cgi->scrolling_list(-name => 'active_subsetC',
846 :     -values => [sort @subset_names],
847 :     -default => $active_subsetC
848 :     ),
849 :     $cgi->br
850 :     );
851 :     }
852 :     else
853 :     {
854 :     push(@$html,$cgi->hidden(-name => 'active_subsetC', -value => 'All', -override => 1));
855 :     }
856 :     }
857 :    
858 :     sub format_subsetsR {
859 :     my($fig,$cgi,$html,$subsystem) = @_;
860 :     my($i);
861 :    
862 :     my $link = &tree_link;
863 :     push(@$html,$cgi->br,$link,$cgi->br);
864 :    
865 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
866 :    
867 :     my @tmp = grep { $_ ne "All" } sort $subsystem->get_subset_namesR;
868 :     push(@$html,$cgi->scrolling_list(-name => 'active_subsetR',
869 :     -values => ["All",@tmp],
870 :     -default => $active_subsetR,
871 :     -size => 5
872 :     ),
873 :     $cgi->br
874 :     );
875 :     }
876 :    
877 :     sub format_existing_subsetsC {
878 :     my($cgi,$html,$subsystem,$tab,$nP) = @_;
879 :     my($nameCS);
880 :    
881 :     foreach $nameCS (sort $subsystem->get_subset_namesC)
882 :     {
883 :     &format_subsetC($cgi,$html,$subsystem,$tab,$$nP,$nameCS);
884 :     $$nP++;
885 :     }
886 :     }
887 :    
888 :     sub format_subsetC {
889 :     my($cgi,$html,$subsystem,$tab,$n,$nameCS) = @_;
890 :    
891 :     if ($nameCS ne "All")
892 :     {
893 :     my $subset = $nameCS ? join(",",map { $subsystem->get_role_index($_) + 1 } $subsystem->get_subsetC($nameCS)) : "";
894 :     my($posT,$subsetT);
895 :     if ($cgi->param('can_alter'))
896 :     {
897 :     $posT = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1);
898 :     $subsetT = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1);
899 :     }
900 :     else
901 :     {
902 :     push(@$html,$cgi->hidden(-name => "nameCS$n", -value => $nameCS, -override => 1),
903 :     $cgi->hidden(-name => "subsetC$n", -value => $subset, -override => 1));
904 :     $posT = $nameCS;
905 :     $subsetT = $subset;
906 :     }
907 :     push(@$tab,[$posT,$subsetT]);
908 :     }
909 :     }
910 :    
911 :     sub tree_link {
912 :     my $target = "window$$";
913 :     my $url = &FIG::cgi_url . "/subsys.cgi?request=show_tree";
914 :     return "<a href=$url target=$target>Show Phylogenetic Tree</a>";
915 :     }
916 :    
917 :     sub format_rows {
918 :     my($fig,$cgi,$html,$subsystem) = @_;
919 :     my($i,%alternatives);
920 :    
921 :     my $ignore_alt = $cgi->param('ignore_alt');
922 :    
923 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
924 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
925 :    
926 :     my @subsetC = $subsystem->get_subsetC($active_subsetC);
927 :     my %activeC = map { $_ => 1 } @subsetC;
928 :    
929 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
930 :     my %activeR = map { $_ => 1 } @subsetR;
931 :    
932 :     if (! $ignore_alt)
933 :     {
934 :     my $subset;
935 :     foreach $subset (grep { $_ =~ /^\*/ } $subsystem->get_subset_namesC)
936 :     {
937 :     my @mem = grep { $activeC{$_} } $subsystem->get_subsetC($subset);
938 :     if (@mem > 1)
939 :     {
940 :     my $mem = [@mem];
941 :     foreach $_ (@mem)
942 :     {
943 :     $alternatives{$_} = [$subset,$mem];
944 :     }
945 :     }
946 :     }
947 :     }
948 :    
949 :     my @in = $subsystem->get_genomes;
950 :    
951 :     if (@in > 0)
952 :     {
953 :     my $col_hdrs = ["Genome ID","Organism","Variant Code"];
954 :    
955 :     my @row_guide = ();
956 :    
957 :     my($role,%in_col);
958 :     foreach $role (grep { $activeC{$_} } $subsystem->get_roles)
959 :     {
960 :     if (! $in_col{$role})
961 :     {
962 :     if ($_ = $alternatives{$role})
963 :     {
964 :     my($abbrev,$mem) = @$_;
965 :     push(@$col_hdrs,$abbrev);
966 :     push(@row_guide,[map { [$_,"-" . ($subsystem->get_role_index($_) + 1)] } @$mem]);
967 :     foreach $_ (@$mem) { $in_col{$_} = 1 };
968 :     }
969 :     else
970 :     {
971 :     push(@$col_hdrs,$subsystem->get_role_abbr($subsystem->get_role_index($role)));
972 :     push(@row_guide,[[$role,""]]);
973 :     }
974 :     }
975 :     }
976 :    
977 :     my $tab = [];
978 :     my($genome,@pegs,@cells,$set,$peg_set,$pair,$role,$suffix,$row,$peg,$color_of,$cell,%count,$color,@colors);
979 :     foreach $genome (grep { $activeR{$_} } @in)
980 :     {
981 :     $row = [$genome, &ext_genus_species($fig,$genome),$subsystem->get_variant_code($subsystem->get_genome_index($genome))];
982 :    
983 :     @pegs = ();
984 :     @cells = ();
985 :     foreach $set (@row_guide)
986 :     {
987 :     $peg_set = [];
988 :     foreach $pair (@$set)
989 :     {
990 :     ($role,$suffix) = @$pair;
991 :     foreach $peg ($fig->seqs_with_role($role,"master",$genome))
992 :     {
993 :     push(@$peg_set,[$peg,$suffix]);
994 :     }
995 :     }
996 :     push(@pegs,map { $_->[0] } @$peg_set);
997 :     push(@cells,$peg_set);
998 :     }
999 :     $color_of = &group_by_clusters($fig,\@pegs);
1000 :     foreach $cell (@cells)
1001 :     {
1002 :     undef %count;
1003 :     foreach $_ (@$cell)
1004 :     {
1005 :     if (($color = $color_of->{$_->[0]}) ne '#FFFFFF')
1006 :     {
1007 :     $count{$color}++;
1008 :     }
1009 :     }
1010 :     @colors = sort { $count{$b} <=> $count{$a} } keys(%count);
1011 :     $color = (@colors > 0) ? $colors[0] : '#FFFFFF';
1012 :     push(@$row,"\@bgcolor=\"$color\":" . join(", ",map { &HTML::fid_link($cgi,$_->[0],"local") . $_->[1] } @$cell));
1013 :     }
1014 :     push(@$tab,$row);
1015 :     }
1016 :    
1017 :    
1018 :     my($sort);
1019 :     if ($sort = $cgi->param('sort'))
1020 :     {
1021 :     if ($sort eq "by_variant")
1022 :     {
1023 :     $tab = [sort { ($a->[2] cmp $b->[2]) or ($a->[1] cmp $b->[1]) } @$tab];
1024 :     }
1025 :     elsif ($sort eq "by_phylo")
1026 :     {
1027 :     $tab = [map { $_->[0] }
1028 :     sort { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) }
1029 :     map { [$_, $fig->taxonomy_of($_->[0])] }
1030 :     @$tab];
1031 :     }
1032 :     elsif ($sort eq "by_tax_id")
1033 :     {
1034 :     $tab = [sort { $a->[0] <=> $b->[0] } @$tab];
1035 :     }
1036 :     elsif ($sort eq "alphabetic")
1037 :     {
1038 :     $tab = [sort { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @$tab];
1039 :     }
1040 :     }
1041 :    
1042 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Basic Spreadsheet"),
1043 :     $cgi->hr
1044 :     );
1045 :    
1046 :     push(@$html,$cgi->scrolling_list(-name => 'sort',
1047 :     -value => ['unsorted','alphabetic','by_variant','by_phylo','by_tax_id'],
1048 :     -default => 'unsorted'
1049 :     ));
1050 :     }
1051 :     }
1052 :    
1053 :     sub group_by_clusters {
1054 :     my($fig,$pegs) = @_;
1055 :     my($peg,@clusters,@cluster,@colors,$color,%seen,%conn,$x,$peg1,@pegs,$i);
1056 :    
1057 :     my $color_of = {};
1058 :     foreach $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }
1059 :    
1060 :     if ($cgi->param('show_clusters'))
1061 :     {
1062 :     @pegs = keys(%$color_of);
1063 :    
1064 :     foreach $peg (@pegs)
1065 :     {
1066 :     foreach $peg1 (grep { $color_of->{$_} && ($_ ne $peg) } $fig->close_genes($peg,5000))
1067 :     {
1068 :     push(@{$conn{$peg}},$peg1);
1069 :     }
1070 :     }
1071 :    
1072 :     @clusters = ();
1073 :     while ($peg = shift @pegs)
1074 :     {
1075 :     if (! $seen{$peg})
1076 :     {
1077 :     @cluster = ($peg);
1078 :     $seen{$peg} = 1;
1079 :     for ($i=0; ($i < @cluster); $i++)
1080 :     {
1081 :     $x = $conn{$cluster[$i]};
1082 :     foreach $peg1 (@$x)
1083 :     {
1084 :     if (! $seen{$peg1})
1085 :     {
1086 :     push(@cluster,$peg1);
1087 :     $seen{$peg1} = 1;
1088 :     }
1089 :     }
1090 :     }
1091 :     push(@clusters,[@cluster]);
1092 :     }
1093 :     }
1094 :    
1095 :     @colors =
1096 :     (
1097 :     '#C0C0C0',
1098 :     '#FF40C0',
1099 :     '#FF8040',
1100 :     '#FF0080',
1101 :     '#FFC040',
1102 :     '#40C0FF',
1103 :     '#40FFC0',
1104 :     '#C08080',
1105 :     '#C0FF00',
1106 :     '#00FF80',
1107 :     '#00C040'
1108 :     );
1109 :    
1110 :     @clusters = grep { @$_ > 1 } sort { @$a <=> @$b } @clusters;
1111 :    
1112 :     if (@clusters > @colors) { splice(@clusters,0,(@clusters - @colors)) } # make sure we have enough colors
1113 :    
1114 :     my($cluster);
1115 :     foreach $cluster (@clusters)
1116 :     {
1117 :     $color = shift @colors;
1118 :     foreach $peg (@$cluster)
1119 :     {
1120 :     $color_of->{$peg} = $color;
1121 :     }
1122 :     }
1123 :     }
1124 :     return $color_of;
1125 :     }
1126 :    
1127 :     sub format_ssa_table {
1128 :     my($cgi,$html,$user,$ssaP) = @_;
1129 :     my($ssa,$curator);
1130 :     my($url1,$link1);
1131 :    
1132 :     my $can_alter = $cgi->param('can_alter');
1133 :     push(@$html, $cgi->start_form(-action => "subsys.cgi",
1134 :     -method => 'post'),
1135 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
1136 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
1137 :     $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1)
1138 :     );
1139 :     push(@$html,"<font size=\"+2\">Please do not ever edit someone else\'s spreadsheet (by using their
1140 :     user ID), and <b>never open multiple windows to
1141 :     process the same spreadsheet</b></font>. It is, of course, standard practice to open a subsystem
1142 :     spreadsheet and then to have multiple other SEED windows to access data and modify annotations. Further,
1143 :     you can access someone else's subsystem spreadsheet using your ID (which will make it impossible
1144 :     for you to edit the spreadsheet).
1145 :     Just do not open the same subsystem spreadsheet for editing in multiple windows simultaneously.",
1146 :     $cgi->br,
1147 :     $cgi->br
1148 :     );
1149 :    
1150 :     my $col_hdrs = [
1151 :     "Name","Curator","Exchangable","Version",
1152 :     "Reset to Previous Timestamp","Delete",
1153 :     "Export Full Subsystem","Export Just Assignments", "Publish to Clearinghouse",
1154 :     ];
1155 :     my $title = "Existing Subsystem Annotations";
1156 :     my $tab = [];
1157 :     foreach $_ (@$ssaP)
1158 :     {
1159 :     my($publish_checkbox);
1160 :     ($ssa,$curator) = @$_;
1161 :    
1162 :     my($url,$link);
1163 :     if ((-d "$FIG_Config::data/Subsystems/$ssa/Backup") && ($curator eq $cgi->param('user')))
1164 :     {
1165 :     $url = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$ssa&request=reset";
1166 :     $link = "<a href=$url>reset</a>";
1167 :     }
1168 :     else
1169 :     {
1170 :     $link = "";
1171 :     }
1172 :    
1173 :     if (($fig->is_exchangable_subsystem($ssa)) && ($curator eq $cgi->param('user')))
1174 :     {
1175 :     $url1 = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$ssa&request=make_unexchangable";
1176 :     $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>";
1177 :     }
1178 :     elsif ($curator eq $cgi->param('user'))
1179 :     {
1180 :     $url1 = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$ssa&request=make_exchangable";
1181 :     $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>";
1182 :     }
1183 :     else
1184 :     {
1185 :     $link1 = "";
1186 :     }
1187 :    
1188 :     #
1189 :     # Only allow publish for subsystems we are curating?
1190 :     #
1191 :     if ($curator eq $cgi->param('user'))
1192 :     {
1193 :     $publish_checkbox = $cgi->checkbox(-name => "publish_to_clearinghouse",
1194 :     -value => $ssa,
1195 :     -label => "Publish"),
1196 :    
1197 :     }
1198 :    
1199 :     push(@$tab,[
1200 :     &ssa_link($ssa,$user),
1201 :     $curator,
1202 :     $link1,
1203 :     $fig->subsystem_version($ssa),
1204 :     $link,
1205 :     ($curator eq $cgi->param('user')) ? $cgi->checkbox(-name => "delete", -value => $ssa) : "",
1206 :     $cgi->checkbox(-name => "export", -value => $ssa, -label => "Export full"),
1207 :     $cgi->checkbox(-name => "export_assignments", -value => $ssa, -label => "Export assignments"),
1208 :     $publish_checkbox,
1209 :     ]);
1210 :     }
1211 :     push(@$html,
1212 :     &HTML::make_table($col_hdrs,$tab,$title),
1213 :     $cgi->submit(-name => 'delete_export',
1214 :     -label => 'Process marked deletions and exports'),
1215 :     $cgi->submit(-name => 'publish',
1216 :     -label => "Publish marked subsystems"),
1217 :     $cgi->end_form
1218 :     );
1219 :     }
1220 :    
1221 :     sub existing_subsystem_annotations {
1222 :     my($ssa,$name);
1223 :     my @ssa = ();
1224 :     if (opendir(SSA,"$FIG_Config::data/Subsystems"))
1225 :     {
1226 :     @ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/[ \/]/_/g; [$name,&curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA);
1227 :     closedir(SSA);
1228 :     }
1229 :     return sort { $a->[0] cmp $b->[0] } @ssa;
1230 :     }
1231 :    
1232 :     sub ssa_link {
1233 :     my($ssa,$user) = @_;
1234 :     my $name = $ssa; $name =~ s/_/ /g;
1235 :     my $target = "window$$";
1236 :     my $can_alter = &curator($ssa) eq $user;
1237 :    
1238 :     my $url = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$ssa&request=show_ssa&can_alter=$can_alter";
1239 :     return "<a href=$url target=$target>$name</a>";
1240 :     }
1241 :    
1242 :     sub curator {
1243 :     my($ssa) = @_;
1244 :     my($who) = "";
1245 :    
1246 :     if (open(DATA,"<$FIG_Config::data/Subsystems/$ssa/curation.log"))
1247 :     {
1248 :     $_ = <DATA>;
1249 :     if ($_ =~ /^\d+\t(\S+)\s+started/)
1250 :     {
1251 :     $who = $1;
1252 :     }
1253 :     close(DATA);
1254 :     }
1255 :     return $who;
1256 :     }
1257 :    
1258 :     sub log_update {
1259 :     my($ssa,$user) = @_;
1260 :    
1261 :     $ssa =~ s/[ \/]/_/g;
1262 :    
1263 :     if (open(LOG,">>$FIG_Config::data/Subsystems/$ssa/curation.log"))
1264 :     {
1265 :     my $time = time;
1266 :     print LOG "$time\t$user\tupdated\n";
1267 :     close(LOG);
1268 :     }
1269 :     else
1270 :     {
1271 :     print STDERR "failed to open $FIG_Config::data/Subsystems/$ssa/curation.log\n";
1272 :     }
1273 :     }
1274 :    
1275 :     sub export {
1276 :     my($fig,$cgi,$ssa) = @_;
1277 :     my($line);
1278 :    
1279 :     my ($exportable,$notes) = $fig->exportable_subsystem($ssa);
1280 :     foreach $line (@$exportable,@$notes)
1281 :     {
1282 :     print $line;
1283 :     }
1284 :     }
1285 :    
1286 :     sub export_assignments {
1287 :     my($fig,$cgi,$ssa) = @_;
1288 :     my(@roles,$i,$entry,$id,$user);
1289 :    
1290 :     if (($user = $cgi->param('user')) && open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
1291 :     {
1292 :     $user =~ s/^master://;
1293 :     &FIG::verify_dir("$FIG_Config::data/Assignments/$user");
1294 :     my $who = &curator($ssa);
1295 :     my $file = &FIG::epoch_to_readable(time) . ":$who:generated_from_subsystem_$ssa";
1296 :    
1297 :     if (open(OUT,">$FIG_Config::data/Assignments/$user/$file"))
1298 :     {
1299 :     while (defined($_ = <SSA>) && ($_ !~ /^\/\//))
1300 :     {
1301 :     chop;
1302 :     push(@roles,$_);
1303 :     }
1304 :     while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) {}
1305 :     while (defined($_ = <SSA>))
1306 :     {
1307 :     chop;
1308 :     my @flds = split(/\t/,$_);
1309 :     my $genome = $flds[0];
1310 :     for ($i=2; ($i < @flds); $i++)
1311 :     {
1312 :     my @entries = split(/,/,$flds[$i]);
1313 :     foreach $id (@entries)
1314 :     {
1315 :     my $peg = "fig|$genome.peg.$id";
1316 :     my $func = $fig->function_of($peg);
1317 :     print OUT "$peg\t$func\n";
1318 :     }
1319 :     }
1320 :     }
1321 :     close(OUT);
1322 :     }
1323 :     close(SSA);
1324 :     }
1325 :     }
1326 :    
1327 :     sub format_missing {
1328 :     my($fig,$cgi,$html,$subsystem) = @_;
1329 :     my($org,$abr,$role,$missing);
1330 :    
1331 :     $user = $cgi->param('user');
1332 :    
1333 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
1334 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
1335 :    
1336 :     my @subsetC = $subsystem->get_subsetC($active_subsetC);
1337 :     my %activeC = map { $_ => 1 } @subsetC;
1338 :    
1339 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
1340 :    
1341 :     my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
1342 :     my($set,$col,%in);
1343 :     foreach $set (@alt_sets)
1344 :     {
1345 :     my @mem = grep { $activeC{$_} } $subsystem->get_subsetC($set);
1346 :     foreach $col (@mem)
1347 :     {
1348 :     $in{$col} = $set;
1349 :     }
1350 :     }
1351 :     push(@$html,$cgi->h1('To Check Missing Entries:'));
1352 :    
1353 :     foreach $org (@subsetR)
1354 :     {
1355 :     my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
1356 :    
1357 :     $missing = [];
1358 :     foreach $role (@missing)
1359 :     {
1360 :     $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role));
1361 :     my $roleE = $cgi->escape($role);
1362 :    
1363 :     my $link = "<a href=" . &FIG::cgi_url . "/pom.cgi?user=$user&request=find_in_org&role=$roleE&org=$org>$abr $role</a>";
1364 :     push(@$missing,$link);
1365 :     }
1366 :    
1367 :     if (@$missing > 0)
1368 :     {
1369 :     my $genus_species = &ext_genus_species($fig,$org);
1370 :     push(@$html,$cgi->h2("$org: $genus_species"));
1371 :     push(@$html,$cgi->ul($cgi->li($missing)));
1372 :     }
1373 :     }
1374 :     }
1375 :    
1376 :     sub columns_missing_entries {
1377 :     my($cgi,$subsystem,$org,$roles,$in) = @_;
1378 :    
1379 :     next if (($_ = $cgi->param('just_genome')) && ($org != $_));
1380 :     my $just_col = $cgi->param('just_col');
1381 :     my(@really_missing) = ();
1382 :    
1383 :     my($role,%missing_cols);
1384 :     foreach $role (@$roles)
1385 :     {
1386 :     next if ($just_col && ($role ne $just_col));
1387 :     if ($subsystem->get_pegs_from_cell($org,$role) == 0)
1388 :     {
1389 :     $missing_cols{$role} = 1;
1390 :     }
1391 :     }
1392 :    
1393 :     foreach $role (@$roles)
1394 :     {
1395 :     if ($missing_cols{$role})
1396 :     {
1397 :     my($set);
1398 :     if (($set = $in->{$role}) && (! $cgi->param('ignore_alt')))
1399 :     {
1400 :     my @set = $subsystem->get_subsetS($set);
1401 :    
1402 :     my($k);
1403 :     for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
1404 :     if ($k == @set)
1405 :     {
1406 :     push(@really_missing,$role);
1407 :     }
1408 :     }
1409 :     else
1410 :     {
1411 :     push(@really_missing,$role);
1412 :     }
1413 :     }
1414 :     }
1415 :     return @really_missing;
1416 :     }
1417 :    
1418 :     sub format_missing_including_matches
1419 :     {
1420 :     my($fig,$cgi,$html,$subsystem) = @_;
1421 :     my($org,$abr,$role,$missing);
1422 :    
1423 :     my $user = $cgi->param('user');
1424 :    
1425 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
1426 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
1427 :    
1428 :     my @subsetC = $subsystem->get_subsetC($active_subsetC);
1429 :     my %activeC = map { $_ => 1 } @subsetC;
1430 :    
1431 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
1432 :    
1433 :     my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
1434 :     my($set,$col,%in);
1435 :     foreach $set (@alt_sets)
1436 :     {
1437 :     my @mem = grep { $activeC{$_} } $subsystem->get_subsetC($set);
1438 :     foreach $col (@mem)
1439 :     {
1440 :     $in{$col} = $set;
1441 :     }
1442 :     }
1443 :     push(@$html,$cgi->h1('To Check Missing Entries:'));
1444 :    
1445 :     push(@$html, $cgi->start_form(-action=> "fid_checked.cgi"));
1446 :    
1447 :     my $can_alter = $cgi->param('can_alter');
1448 :     push(@$html,
1449 :     $cgi->hidden(-name => 'user', -value => $user, -override => 1),
1450 :     $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1));
1451 :    
1452 :     foreach $org (@subsetR)
1453 :     {
1454 :     my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
1455 :     $missing = [];
1456 :    
1457 :     foreach $role (@missing)
1458 :     {
1459 :     next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1)));
1460 :     $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role));
1461 :     my $roleE = $cgi->escape($role);
1462 :    
1463 :     #
1464 :     # All the way up to here is code to retrieve the role name.
1465 :     #
1466 :    
1467 :     #
1468 :     # Invoke find_role_in_org to get the roles we might have.
1469 :     #
1470 :    
1471 :     my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff"));
1472 :    
1473 :     push(@$missing,@hits);
1474 :     }
1475 :    
1476 :     my $genus_species = &ext_genus_species($fig,$org);
1477 :     push(@$html,$cgi->h2("$org: $genus_species"));
1478 :    
1479 :     if (@$missing > 0)
1480 :     {
1481 :     my $colhdr = ["Assign", "P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"];
1482 :     my $tbl = [];
1483 :    
1484 :     for my $hit (@$missing)
1485 :     {
1486 :     my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit;
1487 :    
1488 :     my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1);
1489 :     my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0);
1490 :    
1491 :     my $checkbox = $cgi->checkbox(-name => "checked",
1492 :     -value => "to=$my_peg,from=$match_peg",
1493 :     -label => "");
1494 :    
1495 :     push(@$tbl, [$checkbox,
1496 :     $psc,
1497 :     $my_peg_link, $my_len, $my_fn,
1498 :     $match_peg_link, $match_len, $match_fn]);
1499 :     }
1500 :    
1501 :     push(@$html, &HTML::make_table($colhdr, $tbl, ""));
1502 :     }
1503 :     else
1504 :     {
1505 :     push(@$html, $cgi->p("No matches."));
1506 :     }
1507 :    
1508 :     }
1509 :     push(@$html,
1510 :     $cgi->submit(-value => "Process assignments",
1511 :     -name => "batch_assign"),
1512 :     $cgi->end_form);
1513 :     }
1514 :    
1515 :     sub format_dups {
1516 :     my($fig,$cgi,$html,$subsystem) = @_;
1517 :    
1518 :     my $user = $cgi->param('user');
1519 :    
1520 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
1521 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
1522 :    
1523 :     my @subsetC = $subsystem->get_subsetC($active_subsetC);
1524 :     my %activeC = map { $_ => 1 } @subsetC;
1525 :    
1526 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
1527 :    
1528 :     push(@$html,$cgi->h1('To Check Duplicates:'));
1529 :    
1530 :     my($org,$duplicates,$role,$genus_species);
1531 :     foreach $org (@subsetR)
1532 :     {
1533 :     $duplicates = [];
1534 :     foreach $role (@subsetC)
1535 :     {
1536 :     my(@pegs,$peg,$func);
1537 :     if ((@pegs = $subsystem->get_pegs_from_cell($org,$role)) > 1)
1538 :     {
1539 :     push(@$duplicates,"$role<br>" . $cgi->ul($cgi->li([map { $peg = $_; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } @pegs])));
1540 :     }
1541 :     }
1542 :    
1543 :     if (@$duplicates > 0)
1544 :     {
1545 :     $genus_species = &ext_genus_species($fig,$org);
1546 :     push(@$html,$cgi->h2("$org: $genus_species"));
1547 :     push(@$html,$cgi->ul($cgi->li($duplicates)));
1548 :     }
1549 :     }
1550 :     }
1551 :    
1552 :     sub format_coupled {
1553 :     my($fig,$cgi,$html,$subsystem,$type) = @_;
1554 :     my($i,$j,@show,$user,$org,$link,$gs,$func,$peg,$peg1,$peg2,%in,%seen,%seen2);
1555 :     my(@cluster,$sc,$x,$id2,@in,$sim,@coupled);
1556 :     my($org,$role);
1557 :    
1558 :     $user = $cgi->param('user');
1559 :    
1560 :     my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
1561 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
1562 :    
1563 :     my @subsetC = $subsystem->get_subsetC($active_subsetC);
1564 :     my %activeC = map { $_ => 1 } @subsetC;
1565 :    
1566 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
1567 :    
1568 :     foreach $org (@subsetR)
1569 :     {
1570 :     foreach $role (@subsetC)
1571 :     {
1572 :     push(@in,$subsystem->get_pegs_from_cell($org,$role));
1573 :     }
1574 :     }
1575 :    
1576 :     %in = map { $_ => 1 } @in;
1577 :     @show = ();
1578 :     foreach $peg1 (@in)
1579 :     {
1580 :     if ($type eq "careful")
1581 :     {
1582 :     @coupled = $fig->coupling_and_evidence($peg1,5000,1.0e-10,0.2,1);
1583 :     }
1584 :     else
1585 :     {
1586 :     @coupled = $fig->fast_coupling($peg1,5000,1);
1587 :     }
1588 :    
1589 :     foreach $x (@coupled)
1590 :     {
1591 :     ($sc,$peg2) = @$x;
1592 :     if ((! $in{$peg2}) && ((! $seen{$peg2}) || ($seen{$peg2} < $sc)))
1593 :     {
1594 :     $seen{$peg2} = $sc;
1595 :     # print STDERR "$sc\t$peg1 -> $peg2\n";
1596 :     }
1597 :     }
1598 :     }
1599 :    
1600 :     foreach $peg1 (sort { $seen{$b} <=> $seen{$a} } keys(%seen))
1601 :     {
1602 :     if (! $seen2{$peg1})
1603 :     {
1604 :     @cluster = ($peg1);
1605 :     $seen2{$peg1} = 1;
1606 :     for ($i=0; ($i < @cluster); $i++)
1607 :     {
1608 :     foreach $sim ($fig->sims($cluster[$i],1000,1.0e-10,"fig"))
1609 :     {
1610 :     $id2 = $sim->id2;
1611 :     if ($seen{$id2} && (! $seen2{$id2}))
1612 :     {
1613 :     push(@cluster,$id2);
1614 :     $seen2{$id2} = 1;
1615 :     }
1616 :     }
1617 :     }
1618 :     push(@show, [scalar @cluster,
1619 :     $cgi->br .
1620 :     $cgi->ul($cgi->li([map { $peg = $_;
1621 :     $sc = $seen{$peg};
1622 :     $func = $fig->function_of($peg,$user);
1623 :     $gs = $fig->genus_species($fig->genome_of($peg));
1624 :     $link = &HTML::fid_link($cgi,$peg);
1625 :     "$sc: $link: $func \[$gs\]" }
1626 :     sort { $seen{$b} <=> $seen{$a} }
1627 :     @cluster]))
1628 :     ]);
1629 :     }
1630 :     }
1631 :    
1632 :     if (@show > 0)
1633 :     {
1634 :     @show = map { $_->[1] } sort { $b->[0] <=> $a->[0] } @show;
1635 :     push(@$html,$cgi->h1('Coupled, but not in Spreadsheet:'));
1636 :     push(@$html,$cgi->ul($cgi->li(\@show)));
1637 :     }
1638 :     }
1639 :    
1640 :     sub ext_genus_species {
1641 :     my($fig,$genome) = @_;
1642 :    
1643 :     my $gs = $fig->genus_species($genome);
1644 :     my $c = substr($fig->taxonomy_of($genome),0,1);
1645 :     return "$gs [$c]";
1646 :     }
1647 :    
1648 :     sub show_tree {
1649 :    
1650 :     my($id,$gs);
1651 :     my($tree,$ids) = $fig->build_tree_of_complete;
1652 :     my $relabel = {};
1653 :     foreach $id (@$ids)
1654 :     {
1655 :     if ($gs = $fig->genus_species($id))
1656 :     {
1657 :     $relabel->{$id} = "$gs ($id)";
1658 :     }
1659 :     }
1660 :     $_ = &display_tree($tree,$relabel);
1661 :     print $cgi->pre($_),"\n";
1662 :     }
1663 :    
1664 :     sub export_align_input
1665 :     {
1666 :    
1667 :     }
1668 :    
1669 :     sub align_column {
1670 :     my($fig,$cgi,$html,$col,$subsystem) = @_;
1671 :     my($colN,@checked,$cutoff);
1672 :    
1673 :     my $checked;
1674 :     my $roles = [$subsystem->get_roles];
1675 :     if (($colN = &which_column($col,$roles)) &&
1676 :     ((@checked = &seqs_to_align($colN,$subsystem)) > 1))
1677 :     {
1678 :     if ($cutoff = $cgi->param('include_homo'))
1679 :     {
1680 :     my $max = $cgi->param('max_homo');
1681 :     $max = $max ? $max : 100;
1682 :     push(@checked,&get_homologs($fig,\@checked,$cutoff,$max));
1683 :     }
1684 :     $checked = join("\' \'",@checked);
1685 :     }
1686 :     else
1687 :     {
1688 :     push(@$html,"<h1>You need to check at least two sequences</h1>\n");
1689 :     return;
1690 :     }
1691 :    
1692 :    
1693 :     #
1694 :     # See if we want to produce the alignment, or just produce the
1695 :     # input to the alignment.
1696 :     #
1697 :    
1698 :     if ($cgi->param("show_align_input"))
1699 :     {
1700 :     push(@$html, "<pre>\n");
1701 :     my $relabel;
1702 :     foreach my $id (@checked)
1703 :     {
1704 :     my $seq;
1705 :     if ($seq = $fig->get_translation($id))
1706 :     {
1707 :     push(@$html, ">$id\n$seq\n");
1708 :     my $func = $fig->function_of($id);
1709 :     $relabel->{$id} = "$id: $func";
1710 :     }
1711 :     else
1712 :     {
1713 :     push(@$html, "could not find translation for $id\n");
1714 :     }
1715 :     }
1716 :     push(@$html, "\n</pre>\n");
1717 :     }
1718 :     else
1719 :     {
1720 :     push(@$html,"<pre>\n");
1721 :     my %org = map { ( $_, $fig->org_of($_) ) } @checked;
1722 :     # Modified by GJO to compress tree and add organism names to tree:
1723 :     # push(@$html,`$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'`);
1724 :    
1725 :     # Simpler version
1726 :     # push @$html, map { chomp;
1727 :     # /^ *\|[ |]*$/ # line that adds only tree height
1728 :     # ? () # remove it
1729 :     # : /- ([a-z]+\|\S+):/ && defined( $org{$1} ) # tree id?
1730 :     # ? "$_ [$org{$1}]\n" # add the name
1731 :     # : "$_\n" # otherwise leave unmodified
1732 :     # } `$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'`;
1733 :    
1734 :     # More complex version the preserves double spaced tree tips
1735 :     my $tip = 0;
1736 :     my @out = ();
1737 :    
1738 :     foreach ( `$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'` )
1739 :     {
1740 :     chomp;
1741 :     if ( /^ *\|[ |]*$/ ) {} # line that adds only tree height
1742 :     elsif ( /- ([a-z]+\|\S+):/ ) # line with tree tip
1743 :     {
1744 :     if ( defined( $org{$1} ) ) { $_ .= " [$org{$1}]" } # add org
1745 :     if ( $tip ) { push @out, " |\n" } # 2 tips in a row? add line
1746 :     push @out, "$_\n"; # output current line
1747 :     $tip = 1;
1748 :     }
1749 :     else # not a tip
1750 :     {
1751 :     push @out, "$_\n";
1752 :     $tip = 0;
1753 :     }
1754 :     }
1755 :     push(@$html,&set_links($cgi,\@out));
1756 :     push(@$html,"</pre>\n");
1757 :     }
1758 :     }
1759 :    
1760 :     sub which_column {
1761 :     my($col,$roles) = @_;
1762 :     my($i);
1763 :    
1764 :     if (($col =~ /^(\d+)/) && ($1 <= @$roles))
1765 :     {
1766 :     return $roles->[$1-1];
1767 :     }
1768 :     return undef;
1769 :     }
1770 :    
1771 :     sub seqs_to_align {
1772 :     my($role,$subsystem) = @_;
1773 :     my($genome);
1774 :    
1775 :     my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
1776 :     my @subsetR = $subsystem->get_subsetR($active_subsetR);
1777 :    
1778 :     my @seqs = ();
1779 :     foreach $genome (@subsetR)
1780 :     {
1781 :     push(@seqs,$subsystem->get_pegs_from_cell($genome,$role));
1782 :     }
1783 :     return @seqs;
1784 :     }
1785 :    
1786 :     sub get_homologs {
1787 :     my($fig,$checked,$cutoff,$max) = @_;
1788 :     my($peg,$sim,$id2);
1789 :    
1790 :     my @homologs = ();
1791 :     my %got = map { $_ => 1 } @$checked;
1792 :    
1793 :     foreach $peg (@$checked)
1794 :     {
1795 :     foreach $sim ($fig->sims($peg,$max,$cutoff,"fig"))
1796 :     {
1797 :     $id2 = $sim->id2;
1798 :     if (! $got{$id2})
1799 :     {
1800 :     push(@homologs,[$sim->psc,$id2]);
1801 :     $got{$id2} = 1;
1802 :     }
1803 :     }
1804 :     }
1805 :     @homologs = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @homologs;
1806 :     if (@homologs > $max) { $#homologs = $max-1 }
1807 :    
1808 :     return @homologs;
1809 :     }
1810 :    
1811 :     sub set_links {
1812 :     my($cgi,$out) = @_;
1813 :    
1814 :     my @with_links = ();
1815 :     foreach $_ (@$out)
1816 :     {
1817 :     if ($_ =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
1818 :     {
1819 :     my($before,$peg,$after) = ($1,$2,$3);
1820 :     push(@with_links, $before . &HTML::fid_link($cgi,$peg) . $after . "\n");
1821 :     }
1822 :     else
1823 :     {
1824 :     push(@with_links,$_);
1825 :     }
1826 :     }
1827 :     return @with_links;
1828 :     }
1829 :    
1830 :     sub backup {
1831 :     my($ssaD) = @_;
1832 :    
1833 :     my $sz1 = &size("$ssaD/spreadsheet") + &size("$ssaD/notes");
1834 :     my $sz2 = &size("$ssaD/spreadsheet~") + &size("$ssaD/notes~");
1835 :     if (abs($sz1-$sz2) > 10)
1836 :     {
1837 :     &make_backup($ssaD);
1838 :     }
1839 :     }
1840 :    
1841 :     sub make_backup {
1842 :     my($ssaD) = @_;
1843 :    
1844 :     &FIG::verify_dir("$ssaD/Backup");
1845 :     my $ts = time;
1846 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
1847 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
1848 :     &incr_version($ssaD);
1849 :     }
1850 :    
1851 :     sub incr_version {
1852 :     my($dir) = @_;
1853 :     my($ver);
1854 :    
1855 :     if (open(VER,"<$dir/VERSION"))
1856 :     {
1857 :     if (defined($ver = <VER>) && ($ver =~ /^(\S+)/))
1858 :     {
1859 :     $ver = $1;
1860 :     }
1861 :     else
1862 :     {
1863 :     $ver = 0;
1864 :     }
1865 :     close(VER);
1866 :     }
1867 :     else
1868 :     {
1869 :     $ver = 0;
1870 :     }
1871 :     open(VER,">$dir/VERSION") || die "could not open $dir/VERSION";
1872 :     chmod(0777,"$dir/VERSION");
1873 :     $ver++;
1874 :     print VER "$ver\n";
1875 :     }
1876 :    
1877 :    
1878 :     sub size {
1879 :     my($file) = @_;
1880 :    
1881 :     return (-s $file) ? -s $file : 0;
1882 :     }
1883 :    
1884 :     sub reset_ssa {
1885 :     my($fig,$cgi,$html) = @_;
1886 :     my($ssa,@spreadsheets,$col_hdrs,$tab,$t,$readable,$url,$link,@tmp);
1887 :    
1888 :     if (($ssa = $cgi->param('ssa_name')) && opendir(BACKUP,"$FIG_Config::data/Subsystems/$ssa/Backup"))
1889 :     {
1890 :     @spreadsheets = sort { $b <=> $a }
1891 :     map { $_ =~ /^spreadsheet.(\d+)/; $1 }
1892 :     grep { $_ =~ /^spreadsheet/ }
1893 :     readdir(BACKUP);
1894 :     closedir(BACKUP);
1895 :     $col_hdrs = ["When","Number Genomes"];
1896 :     $tab = [];
1897 :     foreach $t (@spreadsheets)
1898 :     {
1899 :     $readable = &FIG::epoch_to_readable($t);
1900 :     $url = &FIG::cgi_url . "/subsys.cgi?user=$user&ssa_name=$ssa&request=reset_to&ts=$t";
1901 :     $link = "<a href=$url>$readable</a>";
1902 :     open(TMP,"<$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t")
1903 :     || die "could not open $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t";
1904 :     $/ = "//\n";
1905 :     $_ = <TMP>;
1906 :     $_ = <TMP>;
1907 :     $_ = <TMP>;
1908 :     chomp;
1909 :     $/ = "\n";
1910 :    
1911 :     @tmp = grep { $_ =~ /^\d+\.\d+/ } split(/\n/,$_);
1912 :     push(@$tab,[$link,scalar @tmp]);
1913 :     }
1914 :     }
1915 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Possible Points to Reset From"));
1916 :     }
1917 :    
1918 :     sub reset_ssa_to {
1919 :     my($fig,$cgi,$html) = @_;
1920 :     my($ts,$ssa);
1921 :    
1922 :     if (($ssa = $cgi->param('ssa_name')) &&
1923 :     ($ts = $cgi->param('ts')) &&
1924 :     (-s "$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts"))
1925 :     {
1926 :     system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts $FIG_Config::data/Subsystems/$ssa/spreadsheet";
1927 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet");
1928 :     if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts")
1929 :     {
1930 :     system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts $FIG_Config::data/Subsystems/$ssa/notes";
1931 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
1932 :     }
1933 :     &reset_peg_subsystem_connections($fig,$ssa); # you must break and restore connections of pegs to subsystem
1934 :     push(@$html,$cgi->h1("Reset"));
1935 :     }
1936 :     }
1937 :    
1938 :     sub make_exchangable {
1939 :     my($fig,$cgi,$html) = @_;
1940 :     my($ssa);
1941 :    
1942 :     if (($ssa = $cgi->param('ssa_name')) &&
1943 :     (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet") &&
1944 :     open(TMP,">$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
1945 :     {
1946 :     print TMP "1\n";
1947 :     close(TMP);
1948 :     chmod(0777,"$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
1949 :     }
1950 :     }
1951 :    
1952 :     sub make_unexchangable {
1953 :     my($fig,$cgi,$html) = @_;
1954 :     my($ssa);
1955 :    
1956 :     if (($ssa = $cgi->param('ssa_name')) &&
1957 :     (-s "$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
1958 :     {
1959 :     unlink("$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
1960 :     }
1961 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3