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

Annotation of /FigWebServices/ssa2.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3