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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.105 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3