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

Annotation of /FigWebServices/resolve_paralogs.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 :     #
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 :     use FIG;
20 :     my $fig = new FIG;
21 : overbeek 1.2 use strict;
22 : golsen 1.4 use clustaltree; # tree_with_clustal()
23 : overbeek 1.2 use gjoalignment;
24 :     use gjonewicklib;
25 :     use ParalogResolution;
26 :     use HTML;
27 : overbeek 1.1
28 :     use CGI;
29 :     my $cgi = new CGI;
30 :    
31 :     if (0)
32 :     {
33 :     my $VAR1;
34 :     eval(join("",`cat /tmp/resolve_parlogs`));
35 :     $cgi = $VAR1;
36 :     # print STDERR &Dumper($cgi);
37 :     }
38 :    
39 : golsen 1.4 if (0)
40 : overbeek 1.1 {
41 :     print $cgi->header;
42 :     my @params = $cgi->param;
43 :     print "<pre>\n";
44 :     foreach $_ (@params)
45 :     {
46 : golsen 1.4 print "$_\t:",join(",",$cgi->param($_)),":\n";
47 : overbeek 1.1 }
48 :    
49 :     if (0)
50 :     {
51 :     if (open(TMP,">/tmp/resolve_paralogs"))
52 :     {
53 :     print TMP &Dumper($cgi);
54 :     close(TMP);
55 :     }
56 :     }
57 :     exit;
58 :     }
59 : golsen 1.4
60 : golsen 1.6 my $align = $cgi->param('align');
61 :     my $e_value = $cgi->param('e_value') || 1e-5;
62 :     my @genomes = current_genomes( $cgi );
63 :     my $keep_mf = $cgi->param('keep_mf');
64 :     my @roles = current_roles( $cgi );
65 :     my $seed = -e 'seedviewer.cgi' ? $cgi->param('seed') : 1;
66 : golsen 1.12 my $tree_prog = $cgi->param('tree') || 'clustal'; # or 'muscle'
67 : golsen 1.6 my $user = $cgi->param('user');
68 :     my $min_cov = $cgi->param('min_coverage') || 0.7;
69 :    
70 :     # Values for testing
71 : golsen 1.7 if (0)
72 : golsen 1.6 {
73 :     @genomes = qw( 83333.1 224308.1 224324.1 262724.1 243232.1 196164.1 ) if ! @genomes;
74 :     @roles = ( 'Translation initiation factor 2',
75 :     # 'Translation elongation factor 1 alpha subunit',
76 :     'Translation elongation factor Tu',
77 :     # 'Translation elongation factor 2',
78 :     # 'Translation elongation factor G',
79 :     'GTP-binding protein TypA/BipA',
80 :     # 'GTP-binding protein EngA',
81 :     'GTP-binding protein Era',
82 :     # 'GTPase and tRNA-U34 5-formylation enzyme TrmE',
83 :     # 'GTP-binding and nucleic acid-binding protein YchF',
84 :     ) if ! @roles;
85 :     }
86 :    
87 : golsen 1.9 my $role0 = $roles[0] ? ": $roles[0]" : '';
88 : overbeek 1.2 my @html = ();
89 : golsen 1.11
90 :     my $agent = $ENV{ HTTP_USER_AGENT } || '';
91 :    
92 :     my $height = $agent =~ /Safari/i ? '120%'
93 :     : $agent =~ /Firefox/i ? '100%'
94 :     : '110%';
95 :    
96 :     my $lsize = $agent =~ /Safari/i ? '160%'
97 :     : $agent =~ /Firefox/i ? '130%'
98 :     : '150%';
99 :    
100 :     my $v_pos = $agent =~ /Safari/i ? 'sub'
101 :     : $agent =~ /Firefox/i ? 'base-line'
102 :     : 'base-line';
103 :    
104 : golsen 1.9 push @html, map { map { "$_\n" } split /\n/ } <<End_of_Head;
105 :     <HTML>
106 :     <HEAD>
107 :     <TITLE>SEED paralog resolution tool$role0</TITLE>
108 : golsen 1.11
109 :     <STYLE Type="text/css">
110 :     /* HTML printer graphics tree in unicode box drawing set */
111 :     TABLE.tree {
112 :     font-size: 100%;
113 :     line-height: $height;
114 :     border-width: 0px;
115 :     padding: 0px;
116 :     white-space: nowrap;
117 :     }
118 :     TABLE.tree TR {
119 :     height: $height;
120 :     border-width: 0px;
121 :     padding: 0px;
122 :     }
123 :     TABLE.tree TD {
124 :     border-width: 0px;
125 :     padding: 0px;
126 :     white-space: nowrap;
127 :     }
128 :     TABLE.tree A {
129 :     text-decoration: none;
130 : golsen 1.9 }
131 : golsen 1.11 TABLE.tree INPUT {
132 :     height: 10px; /* ignored by Firefox */
133 :     width: 10px; /* ignored by Firefox */
134 : golsen 1.9 padding: 0px;
135 : golsen 1.11 margin: 0px;
136 :     }
137 :     TABLE.tree PRE {
138 :     font-size: $lsize;
139 :     padding: 0px;
140 :     margin: 0px;
141 :     vertical-align: $v_pos;
142 :     display: inline;
143 :     }
144 :     TABLE.tree SPAN.w { /* used for tree white space */
145 :     color: white;
146 : golsen 1.9 }
147 :     </STYLE>
148 : golsen 1.11
149 : golsen 1.9 <SCRIPT Type="text/javascript" Src="./Html/layout.js"></SCRIPT>
150 : golsen 1.11
151 : golsen 1.9 <LINK Type="text/css" Rel="stylesheet" HRef="./Html/frame.css" />
152 : golsen 1.11
153 : golsen 1.9 </HEAD>
154 :     <BODY>
155 :     End_of_Head
156 : golsen 1.6
157 :     #-------------------------------------------------------------------------------
158 :     # Build a form for changing analysis parameters:
159 :     #-------------------------------------------------------------------------------
160 :    
161 : golsen 1.9 push( @html, $cgi->h3( 'Analysis Paramters' ), "\n",
162 : golsen 1.6 $cgi->start_form(-action => "resolve_paralogs.cgi"),
163 : golsen 1.9 $cgi->hidden( -name => 'genome', -value => \@genomes, -override => 1 ), "\n",
164 :     $cgi->hidden( -name => 'roles', -value => \@roles, -override => 1 ), "\n",
165 : golsen 1.6 "User: ",
166 : golsen 1.9 $cgi->textfield(-name => "user", -size => 20, -override => 1, -value => $user), "<BR />\n",
167 : golsen 1.6 "Blast inclusion e-value: ",
168 : golsen 1.9 $cgi->textfield(-name => "e_value", -size => 20, -override => 1, -value => $e_value), "<BR />\n",
169 : golsen 1.6 "Blast minimum coverage: ",
170 : golsen 1.9 $cgi->textfield(-name => "min_coverage", -size => 20, -override => 1, -value => $min_cov), "<BR />\n",
171 : golsen 1.6 $cgi->hidden( -name => 'user', -value => $user ),
172 :     "Show alignment: ",
173 : golsen 1.9 $cgi->checkbox( -name => 'align', -checked => $align, -override => 1, -label => '' ), "<BR />\n",
174 : golsen 1.6 "Allow multifunctional assignments: ",
175 : golsen 1.9 $cgi->checkbox( -name => 'keep_mf', -checked => $keep_mf, -override => 1, -label => '' ), "<BR />\n",
176 : golsen 1.6 ( -e 'seedviewer.cgi' ? ( "Link to old protein page: ",
177 : golsen 1.9 $cgi->checkbox( -name => 'seed', -checked => $seed, -override => 1, -label => '' ),
178 :     "<BR />\n"
179 : golsen 1.6 )
180 : golsen 1.9 : $cgi->hidden( -name => 'seed', -value => $seed, -override => 1 )
181 : golsen 1.6 ),
182 :     "Tree construction tool: ",
183 :     "<select name=tree>\n",
184 : golsen 1.12 " <option value=clustal" . ( $tree_prog eq 'clustal' ? ' selected' : '' ) . ">clustalw</option>\n",
185 : golsen 1.6 " <option value=muscle" . ( $tree_prog eq 'muscle' ? ' selected' : '' ) . ">muscle</option>\n",
186 : golsen 1.9 "</select>\n","<BR />"
187 : golsen 1.6 );
188 :    
189 :     genome_picker( $fig, $cgi, \@html, \@genomes );
190 :    
191 :     role_picker( $fig, $cgi, \@html, \@roles );
192 :    
193 : golsen 1.9 push( @html, $cgi->submit( 'Update' ), "\n",
194 :     $cgi->end_form, $cgi->br, $cgi->hr, "\n"
195 : golsen 1.6 );
196 :    
197 : golsen 1.9
198 : golsen 1.6 #-------------------------------------------------------------------------------
199 :     # Collect, align and tree the paralogous sequences:
200 : golsen 1.4 #
201 :     # In each @genomes, find all genes with one of the @roles.
202 :     # Find all other similar to genes in each of the @genomes.
203 :     # Align the related genes with muscle, returning the alignment and tree.
204 :     #
205 : golsen 1.6 #-------------------------------------------------------------------------------
206 : overbeek 1.5
207 :     my $parms = { keep_multifunctional => $keep_mf, max_sc => $e_value, min_cov => $min_cov };
208 :    
209 :     my ( $ali, $tree_str ) = &ParalogResolution::reference_set_for_paralogs( \@genomes, \@roles, $parms);
210 : golsen 1.4
211 : golsen 1.9 if ( ! $ali )
212 :     {
213 :     push @html, $cgi->h3( "Less than 2 sequences satisfied the request. Analysis is futile." ), "\n";
214 :     &HTML::show_page($cgi,\@html);
215 :     exit;
216 :     }
217 :    
218 : golsen 1.4 my $tree1;
219 : golsen 1.9 if ( $ali && $tree_prog eq 'clustal' )
220 : golsen 1.4 {
221 : overbeek 1.5 $tree1 = &clustaltree::tree_with_clustal( map { [$_->[0],'',$_->[2]] } @$ali );
222 : golsen 1.4 }
223 : golsen 1.9 elsif ( $tree_str )
224 : golsen 1.4 {
225 :     $tree1 = &gjonewicklib::parse_newick_tree_str( $tree_str );
226 :     }
227 :     my $tree2 = &gjonewicklib::reroot_newick_to_midpoint( $tree1 );
228 :     my $tree3 = &gjonewicklib::aesthetic_newick_tree( $tree2 );
229 : overbeek 1.2
230 : golsen 1.4 # Identify common roles within a given distance of each peg. Produce a
231 :     # tag that is the list of gene roles (identified by numbers) before and
232 :     # after the given peg. Produce a table that translates the role numbers
233 :     # to their actual names.
234 : overbeek 1.2
235 :     my @pegs = map { $_->[0] } @$ali;
236 : golsen 1.4 my( $tags, $table ) = &ParalogResolution::context_tags( \@pegs, 5000 );
237 : overbeek 1.2
238 : golsen 1.4 # Descriptions of the sequences from reference_set_for_paralogs():
239 : overbeek 1.2
240 : golsen 1.4 my %descs = map { $_->[0] => $_->[1] } @$ali;
241 : overbeek 1.2
242 : golsen 1.4 # Build label strings that integrate the label, coloring, and context tags.
243 :     # Put them into the tree.
244 : overbeek 1.2
245 : golsen 1.11 my $labels = &make_labels( $cgi, \%descs, $tags );
246 : golsen 1.9 my $tree = &gjonewicklib::newick_relabel_tips( $tree3, $labels );
247 : golsen 1.4
248 : golsen 1.6 #-------------------------------------------------------------------------------
249 : golsen 1.4 # Build a form, and print the tree in it:
250 : golsen 1.6 #-------------------------------------------------------------------------------
251 : golsen 1.4
252 : golsen 1.6 push @html, "<h2>Tree of Protein Sequences</h2>\n",
253 : golsen 1.4 $cgi->start_form( -method => 'post',
254 :     -target => '_blank',
255 :     -action => 'fid_checked.cgi',
256 :     -name => 'fid_checked'
257 :     ),
258 : golsen 1.9 $cgi->hidden( -name => 'user', -value => $user );
259 :    
260 : golsen 1.11 my $plot_options = { chars => 'html', # html-encoded unicode box set
261 :     format => 'tree_lbl', # line = [ $graphic, $label ]
262 :     dy => 1,
263 :     min_dx => 1,
264 :     width => 64
265 :     };
266 :    
267 :     push @html, "\n",
268 :     "<TABLE Class=tree>\n",
269 :     ( map { my ( $line, $lbl0 ) = @$_;
270 :     my ( $lbl, $tag1, $tag2 ) = ref $lbl0 ? map { $_ || '' } @$lbl0
271 :     : ( '' x 3 );
272 :     # Fix white space for even spacing:
273 :     $line =~ s/((&nbsp;)+)/<SPAN Class=w>$1<\/SPAN>/g;
274 :     $line =~ s/&nbsp;/&#9474;/g;
275 :     # Output line:
276 :     $lbl ? " <TR><TD><PRE>$line</PRE> $lbl</TD><TD Align=right>$tag1</TD><TD>::</TD><TD Align=left>$tag2</TD></TR>\n"
277 :     : " <TR><TD><PRE>$line</PRE></TD><TD Align=right></TD><TD></TD><TD Align=left></TD></TR>\n"
278 :     }
279 :     text_plot_newick( $tree, $plot_options )
280 :     ),
281 :     "</TABLE>\n",
282 :     "\n";
283 : golsen 1.4
284 :    
285 :     push @html, join( "\n", $cgi->br,
286 :     &HTML::java_buttons( "fid_checked", "checked" ),
287 :     $cgi->br, "",
288 :     "For selected (checked) sequences: ",
289 :     $cgi->submit( 'align' ),
290 :     $cgi->submit( 'view annotations' ),
291 :     $cgi->submit( 'show regions' ),
292 :     $cgi->br, ""
293 :     );
294 :    
295 : overbeek 1.5 if ( $user)
296 : golsen 1.4 {
297 :     push @html, $cgi->submit('assign/annotate') . "\n",
298 :     $cgi->br,
299 :     "<a href='Html/help_for_assignments_and_rules.html'>Help on Assignments, Rules, and Checkboxes</a>", "";
300 :     }
301 :    
302 :     push @html, $cgi->end_form . "\n";
303 :    
304 : golsen 1.6 #-------------------------------------------------------------------------------
305 : golsen 1.4 # Write out the roles in the context tags
306 : golsen 1.6 #-------------------------------------------------------------------------------
307 : golsen 1.4
308 :     push @html, "<HR />\n",
309 : golsen 1.6 "<H2>Key to role numbers of genes in context tags</H2>\n",
310 : golsen 1.4 "<TABLE>\n";
311 :     foreach $_ ( @$table )
312 : overbeek 1.2 {
313 : golsen 1.11 push @html, " <TR><TD Align=right>$_->[0]</TD><TD Align=left>$_->[1]</TD></TR>\n";
314 : overbeek 1.2 }
315 :     push(@html,"</TABLE>\n");
316 :    
317 : golsen 1.4 # Do we want to show the alignment?
318 :     if ( $align )
319 :     {
320 :     push @html, join( "\n",
321 :     "<HR /><H3>Alignment:</H3><PRE>",
322 :     ( map { ( ">$_->[0] $_->[1]", $_->[2] =~ m/.{1,60}/g ) } @$ali ),
323 :     "</PRE><BR />\n"
324 :     );
325 :     }
326 :    
327 : overbeek 1.2 &HTML::show_page($cgi,\@html);
328 :    
329 : golsen 1.6 exit;
330 :    
331 :     #===============================================================================
332 :     # End of script; only subroutines below.
333 :     #===============================================================================
334 : golsen 1.4 #
335 :     # \%html_string = make_labels( $cgi, \%descriptions, \%context_tags )
336 :     #
337 :     # context tags are roles before and after the sequence (marked by ::)
338 :     #
339 : golsen 1.6 #-------------------------------------------------------------------------------
340 : overbeek 1.2 sub make_labels
341 :     {
342 : golsen 1.11 my ( $cgi, $descs, $tags ) = @_;
343 : overbeek 1.5
344 : golsen 1.6 my $user = $cgi->param( 'user' );
345 :     my $seed = $cgi->param( 'seed' );
346 : overbeek 1.2
347 : golsen 1.4 my @pegs = keys %$descs;
348 :    
349 :     my %split_description;
350 :     my @pegs_with_func = ();
351 : overbeek 1.2 my %role_count;
352 : golsen 1.4 my %role_color;
353 :     my %check;
354 :     my %from;
355 : overbeek 1.2 my %labels;
356 : golsen 1.4
357 :     #------------------------------------------------------------------
358 :     # Parse the text in to roles, comments and organisms:
359 :     #------------------------------------------------------------------
360 :    
361 :     foreach my $peg ( @pegs )
362 : overbeek 1.2 {
363 : golsen 1.4 my $desc = $descs->{ $peg };
364 :     my ( $func, $roles, $com, $org ) = split_desc( $desc );
365 :     foreach ( @$roles ) { $role_count{ $_ }++ if /[0-9A-Za-z]/ }
366 :     $split_description{ $peg } = [ $func, $roles, $com, $org ];
367 :     push @pegs_with_func, $peg if $func =~ /[0-9A-Za-z]/;
368 : overbeek 1.2 }
369 :    
370 : golsen 1.4 #------------------------------------------------------------------
371 :     # Assign colors to roles:
372 :     #------------------------------------------------------------------
373 :    
374 : overbeek 1.2 my @pallet = ( '#DDCCAA', '#FFAAAA', '#FFCC66', '#FFFF44',
375 :     '#CCFF66', '#88FF88', '#88EECC', '#88FFFF',
376 :     '#66CCFF', '#AAAAFF', '#CC88FF', '#FFAAFF'
377 :     );
378 : golsen 1.4 %role_color = map { $_->[0] => ( shift @pallet ) || '#C0C0C0' }
379 :     sort { $b->[1] <=> $a->[1] }
380 :     map { [ $_, $role_count{ $_ } ] }
381 :     keys %role_count;
382 :    
383 :     #------------------------------------------------------------------
384 :     # Build checkboxes and radio buttons for appropriate sequences:
385 :     #------------------------------------------------------------------
386 :    
387 :     %check = map { $_ => qq(<input type=checkbox name=checked value="$_">) } @pegs;
388 :    
389 : overbeek 1.5 if ( $user )
390 : golsen 1.4 {
391 :     %from = map { m/value=\"([^\"]+)\"/; $1 => $_ }
392 :     $cgi->radio_group( -name => 'from',
393 :     -nolabels => 1,
394 :     -override => 1,
395 :     -values => [ @pegs_with_func ]
396 :     );
397 :     }
398 :    
399 :     #------------------------------------------------------------------
400 :     # Build the actual labels:
401 :     #------------------------------------------------------------------
402 :    
403 :     foreach my $peg ( @pegs )
404 :     {
405 :     my ( $func, $roles, $com, $org ) = @{ $split_description{ $peg } };
406 :     foreach ( @$roles )
407 : overbeek 1.2 {
408 : golsen 1.4 my $color = $role_color{ $_ };
409 :     $_ = "<SPAN Style='background-color:$color'>$_</SPAN>" if $color;
410 : overbeek 1.2 }
411 : golsen 1.4 $func = join( '', @$roles ); # Clobber the original, uncolored string
412 : golsen 1.11
413 :     my $link = $seed ? &HTML::fid_link( $cgi, $peg )
414 :     : "<A HRef=seedviewer.cgi?page=Annotation&feature=$peg&user=$user>$peg</A>&nbsp;";
415 :     my @label;
416 : overbeek 1.5 push @label, $link;
417 : golsen 1.4 push @label, $check{ $peg } if $check{ $peg };
418 :     push @label, $from{ $peg } if $from{ $peg };
419 :     push @label, $func if $func =~ /[0-9A-Za-z]/;
420 :     push @label, $com if $com;
421 :     push @label, "[$org]" if $org;
422 :    
423 :     my $label = join( ' ', @label );
424 :    
425 : golsen 1.11 $labels{ $peg } = [ $label, split /::/, $tags->{ $peg } ];
426 : overbeek 1.2 }
427 : golsen 1.4
428 : overbeek 1.2 return \%labels;
429 :     }
430 :    
431 :    
432 : golsen 1.4 # Split a sequence description string into the roles, the comment and the
433 :     # organism. Further, split the role string into its components and
434 :     # punctuation.
435 :    
436 :     # ( $function, \@roles, $comment, $organism ) = split_desc( $description )
437 :    
438 :     sub split_desc
439 : overbeek 1.2 {
440 :     local $_ = shift;
441 : golsen 1.4 s/\s+/ /g; # White space to single blanks
442 : overbeek 1.2
443 : golsen 1.4 my $org = '';
444 :     s/ $//;
445 :     if ( m/\]$/ )
446 : overbeek 1.2 {
447 : golsen 1.4 my $i = length( $_ ) - 2;
448 :     my $d = 1;
449 :     while ( $d > 0 && $i >= 0 )
450 :     {
451 :     my $c = substr( $_, $i, 1 );
452 :     if ( $c eq '[' ) { $d-- } elsif ( $c eq ']' ) { $d++ }
453 :     if ($d) { $i-- }
454 :     }
455 :     if ( $i >= 0 )
456 :     {
457 :     $org = substr( $_, $i+1, length($_) - $i - 2 ); # Excludes brackets
458 :     $_ = substr( $_, 0, $i );
459 :     s/\s+$//;
460 :     }
461 : overbeek 1.2 }
462 :    
463 : golsen 1.4 my ( $com ) = s/ (\#\#? .*)$//;
464 : overbeek 1.2 $com ||= '';
465 :    
466 : golsen 1.4 my $func = $_;
467 : overbeek 1.2 my @roles = split /(; | @ | \/ )/;
468 :    
469 : golsen 1.4 return ( $func, \@roles, $com, $org );
470 : overbeek 1.2 }
471 :    
472 : golsen 1.6 #-----------------------------------------------------------------------------
473 :     # Determine the current list of roles:
474 :     #-----------------------------------------------------------------------------
475 :    
476 :     sub current_roles
477 :     {
478 :     my ( $cgi ) = @_;
479 :    
480 :     my %roles = map { $_ => 1 } $cgi->param( 'roles' );
481 :    
482 :     foreach ( $cgi->param( 'delete_role' ) ) { $roles{ $_ } = 0 }
483 :     $cgi->delete( 'delete_role' );
484 :    
485 :     if ( $cgi->param( 'new_roles' ) )
486 :     {
487 :     my @new_roles = grep { /\S/ }
488 :     map { s/^\s+//; s/\s+$//; s/\s\s+/ /; $_ }
489 :     split /\r/, $cgi->param( 'new_roles' );
490 :     foreach ( @new_roles ) { $roles{ $_ } = 1 }
491 :     }
492 :     $cgi->delete( 'new_roles' );
493 :    
494 :     sort { lc $a cmp lc $b } grep { $roles{$_} } keys %roles;
495 :     }
496 :    
497 :    
498 :     #-----------------------------------------------------------------------------
499 :     # Selection of roles:
500 :     #-----------------------------------------------------------------------------
501 :    
502 :     sub role_picker
503 :     {
504 :     my( $fig, $cgi, $html, $roles ) = @_;
505 :    
506 :     push @$html, qq(<input type='button' id='role_chooser_link' value='show' onclick='change_element("role_chooser", "show", "hide");'>\n),
507 :     qq(<B>Role Selection</B><BR />\n),
508 :     qq(<span id='role_chooser_content' class='hideme'>\n);
509 :    
510 :     push @$html, "<BR /><B>Current Roles (use check box to remove)</B><BR />\n";
511 :     push @$html, $cgi->hidden( -name => 'roles',
512 :     -value => $roles,
513 :     -override => 1
514 :     ) . "\n";
515 :     foreach ( sort { lc $a cmp lc $b } @$roles )
516 :     {
517 :     push @$html, $cgi->checkbox( -name => 'delete_role',
518 :     -value => $_,
519 :     -label => $_,
520 :     -override => 1
521 :     ),
522 :     $cgi->br, "\n";
523 :     }
524 :    
525 :     push @$html, "<BR /<B>Enter Additional Roles (separated by newlines)</B><BR />\n",
526 :     $cgi->textarea( -name => 'new_roles',
527 :     -rows => 5,
528 :     -cols => 100,
529 :     -override => 1
530 :     ),
531 :     $cgi->br, "\n";
532 :    
533 :     push @$html, "</SPAN>\n";
534 :     }
535 :    
536 :    
537 :     #-----------------------------------------------------------------------------
538 :     # Determine the current list of genomes:
539 :     #-----------------------------------------------------------------------------
540 :    
541 :     sub current_genomes
542 :     {
543 :     my ( $cgi ) = @_;
544 :    
545 : golsen 1.7 my %genomes = map { $_ => 1 } $cgi->param( 'genome' );
546 : golsen 1.6
547 :     foreach ( $cgi->param( 'delete_genome' ) ) { $genomes{ $_ } = 0 }
548 :     $cgi->delete( 'delete_genome' );
549 :    
550 : golsen 1.8 foreach ( $cgi->param( 'new_genomes' ) ) { $genomes{ $_ } = 1 }
551 : golsen 1.6 $cgi->delete( 'new_genomes' );
552 :    
553 :     grep { $genomes{$_} } keys %genomes;
554 :     }
555 :    
556 :    
557 :     #-----------------------------------------------------------------------------
558 :     # Selection list of genomes:
559 :     #-----------------------------------------------------------------------------
560 :    
561 :     sub genome_picker
562 :     {
563 :     my( $fig, $cgi, $html, $genomes ) = @_;
564 :    
565 :     $genomes = [] if ! ref( $genomes ) eq 'ARRAY';
566 :     my %current = map { $_ => 1 } @$genomes;
567 :    
568 :     push @$html, qq(<input type='button' id='genome_chooser_link' value='show' onclick='change_element("genome_chooser", "show", "hide");'>\n),
569 :     qq(<B>Genome Selection</B><BR />\n),
570 :     qq(<span id='genome_chooser_content' class='hideme'>\n);
571 :    
572 :     push @$html, "<BR /><B>Current Genomes (use check box to remove)</B><BR />\n";
573 : golsen 1.7 push @$html, $cgi->hidden( -name => 'genome',
574 : golsen 1.6 -value => $genomes,
575 :     -override => 1
576 :     ) . "\n";
577 :    
578 :     my @with_gs = sort { lc $a->[1] cmp lc $b->[1] }
579 :     map { [ $_, $fig->genus_species_domain( $_ ) ] }
580 :     @$genomes;
581 :    
582 :     # Abbbreviated domain names
583 :    
584 :     my %maindomain = ( Archaea => 'A',
585 :     Bacteria => 'B',
586 :     Eukaryota => 'E',
587 :     Plasmid => 'P',
588 :     Virus => 'V',
589 :     'Environmental Sample' => 'M', # Metagenome
590 :     unknown => 'U'
591 :     );
592 :    
593 :     # Check list of current genomes:
594 :    
595 : golsen 1.9 foreach ( @with_gs )
596 : golsen 1.6 {
597 :     my $domain = $maindomain{ $_->[2] } || '';
598 :     my $label = "$_->[1] [$domain] ($_->[0])";
599 :     push @$html, $cgi->checkbox( -name => 'delete_genome',
600 :     -value => $_->[0],
601 :     -label => $label,
602 :     -override => 1
603 :     ),
604 :     $cgi->br, "\n";
605 :     }
606 :    
607 :     # Building the list of genomes that can be added:
608 :    
609 :     my $req_comp = $cgi->param( 'complete' ) || 'Only "complete"';
610 :     my $complete = ( $req_comp =~ /^all$/i ) ? undef : "complete";
611 :    
612 :     # What domains are to be displayed in the genome picker?
613 :     # These are the canonical domain names defined in compute_genome_counts
614 :     # and entered in the DBMS:
615 :    
616 :     my %label = ( Archaea => 'Archaea [A]',
617 :     Bacteria => 'Bacteria [B]',
618 :     Eukaryota => 'Eucarya [E]',
619 :     Plasmid => 'Plasmids [P]',
620 :     Virus => 'Viruses [V]',
621 :     'Environmental Sample' => 'Environmental (metagenomes) [M]',
622 :     unknown => 'unknown [U]'
623 :     );
624 :    
625 :     # Currently, compute_genome_counts marks everything that is not Archaea,
626 :     # Bacteria or Eukcayra to not complete. So, the completeness status must
627 :     # be ignored on the others.
628 :    
629 :     my %honor_complete = map { $_ => 1 } qw( Archaea Bacteria Eukaryota );
630 :    
631 :     # Requested domains or default:
632 :    
633 :     my @picker_domains = grep { $maindomain{ $_ } }
634 :     $cgi->param( 'picker_domains' );
635 :     if ( ! @picker_domains ) { @picker_domains = qw( Archaea Bacteria Eukaryota ) }
636 :    
637 :     my %picker_domains = map { $_ => 1 } @picker_domains;
638 :    
639 :     # Build domain selection checkboxes:
640 :    
641 :     my @domain_checkboxes = ();
642 :     my %domain_abbrev = reverse %maindomain;
643 :     foreach ( map { $domain_abbrev{ $_ } } qw( A B E P V M U ) )
644 :     {
645 :     push @domain_checkboxes, $cgi->checkbox( -name => 'picker_domains',
646 :     -value => $_,
647 :     -checked => ( $picker_domains{ $_ } ? 1 : 0 ),
648 :     -label => $label{ $_ },
649 :     -override => 1
650 :     )
651 :     }
652 :    
653 :     # Assemble the genome list for the picker. This could be optimized for
654 :     # some special cases, but it is far from rate limiting. Most of the time
655 :     # is looking up the name and domain, not the call to genomes().
656 :     # Filter out current genomes.
657 :     #
658 :     # Each genome is represented as [ gid, genus_species, domain ]
659 :    
660 : golsen 1.8 my @new_orgs = ();
661 : golsen 1.6 foreach my $domain ( @picker_domains )
662 :     {
663 : golsen 1.8 push @new_orgs, map { [ $_, $fig->genus_species_domain( $_ ) ] }
664 :     grep { ! $current{ $_ } }
665 :     $fig->genomes( $complete && $honor_complete{ $domain }, undef, $domain )
666 : golsen 1.6 }
667 :    
668 :     #
669 :     # Put it in the order requested by the user:
670 :     #
671 :     my $pick_order = $cgi->param('pick_order') || 'Alphabetic';
672 :     if ( $pick_order eq "Phylogenetic" )
673 :     {
674 : golsen 1.8 @new_orgs = sort { $a->[-1] cmp $b->[-1] }
675 :     map { push @$_, lc $fig->taxonomy_of( $_->[0] ); $_ }
676 :     @new_orgs;
677 : golsen 1.6 }
678 :     elsif ( $pick_order eq "Genome ID" )
679 :     {
680 : golsen 1.8 @new_orgs = sort { $a->[-1]->[0] <=> $b->[-1]->[0] || $a->[-1]->[1] <=> $b->[-1]->[1] }
681 :     map { push @$_, [ split /\./, $_->[0] ]; $_ }
682 :     @new_orgs;
683 : golsen 1.6 }
684 :     else
685 :     {
686 :     $pick_order = 'Alphabetic';
687 : golsen 1.8 @new_orgs = sort { $a->[-1] cmp $b->[-1] }
688 :     map { push @$_, lc $_->[1]; $_ }
689 :     @new_orgs;
690 : golsen 1.6 }
691 :    
692 :     # Build the displayed name and id list:
693 :    
694 : golsen 1.8 my %new_orgs = map { $_->[0] => "$_->[1] [$maindomain{$_->[2]}] ($_->[0])" } @new_orgs;
695 :     my @new_gids = map { $_->[0] } @new_orgs;
696 : golsen 1.6
697 :     #
698 :     # Radio buttons to let the user choose the order they want for the list:
699 :     #
700 :     my @order_opt = $cgi->radio_group( -name => 'pick_order',
701 :     -values => [ 'Alphabetic', 'Phylogenetic', 'Genome ID' ],
702 :     -default => $pick_order,
703 :     -override => 1
704 :     );
705 :    
706 :     #
707 :     # Radio buttons to let the user choose to include incomplete genomes:
708 :     #
709 :     my @complete = $cgi->radio_group( -name => 'complete',
710 :     -default => $req_comp,
711 :     -values => [ 'All', 'Only "complete"' ],
712 :     -override => 1
713 :     );
714 :    
715 :     #
716 :     # Display the pick list, and options:
717 :     #
718 :     push( @$html, "<BR /><B>Select Genomes to Add</B><BR />\n",
719 :     "<TABLE>\n",
720 :     " <TR VAlign=top>\n",
721 :     " <TD>",
722 : golsen 1.8 $cgi->scrolling_list( -name => 'new_genomes',
723 :     -values => \@new_gids,
724 :     -labels => \%new_orgs,
725 : golsen 1.6 -size => 10,
726 :     -multiple => 1,
727 :     -override => 1
728 :     ),
729 :     " </TD>\n",
730 :    
731 :     " <TD>",
732 : golsen 1.9 join( "<BR />\n", "<b>Order of selection list:</b>", @order_opt,
733 : golsen 1.6 "<b>Completeness?</b>", @complete
734 :     ), "\n",
735 :     " </TD>\n",
736 :    
737 :     " <TD>&nbsp;&nbsp;&nbsp;</TD>\n",
738 :    
739 :     " <TD>\n",
740 : golsen 1.9 join( "<BR />\n", "<B>Include in selection list:</B>", @domain_checkboxes ), "\n",
741 : golsen 1.6 " </TD>\n",
742 :    
743 :     " </TR>\n",
744 :     "</TABLE>\n",
745 :     );
746 :    
747 :     push @$html, "</SPAN>\n";
748 :     }
749 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3