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

Annotation of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.154 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3