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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3