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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3