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

Annotation of /FigWebServices/ssa2.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3