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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3