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

Annotation of /FigWebServices/align_and_tree.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (view) (download)

1 : golsen 1.1 # -*- perl -*-
2 :     #
3 :     # Copyright (c) 2003-2011 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 strict;
20 :     use HTML;
21 :     use FIG_CGI;
22 :     use FIGgjo; # colorize_roles, colorize_functions
23 :     use gjoseqlib; # read_fasta, print_alignment_as_fasta
24 :     use gjoalign2html; # repad_alignment, color_alignment_by_consensus
25 :     use gjonewicklib;
26 :     use SAPserver;
27 :     use AlignsAndTreesServer qw( peg_alignment_metadata
28 :     peg_alignment_by_ID
29 :     peg_tree_by_ID
30 :     aligns_with_pegID
31 : golsen 1.3 get_md5_projections
32 : golsen 1.1 );
33 :    
34 :     use Data::Dumper;
35 :     use Carp;
36 :    
37 :     my( $fig, $cgi, $user ) = FIG_CGI::init( debug_save => 0,
38 :     debug_load => 0,
39 :     print_params => 0 );
40 :    
41 : golsen 1.3 my $sapObject = SAPserver->new();
42 : golsen 1.1
43 : golsen 1.3 # The html will be assembled here.
44 :    
45 :     print $cgi->header;
46 :     my @html = ();
47 :    
48 :     #------------------------------------------------------------------------------
49 :     # Convert the cgi paramater values to a local summary of the work to be done
50 :     #------------------------------------------------------------------------------
51 :    
52 :     my $action = $cgi->param( 'action' ); # assign is the only special action
53 :     my $ali_tree_id = $cgi->param( 'ali_tree_id' ) || '';
54 :     my @ali_tree_ids = $cgi->param( 'at_ids' );
55 :     my $align_format = $cgi->param( 'align_format' ); # default || fasta || clustal
56 :     my $align_id = $cgi->param( 'align_id' );
57 :     my $au = $cgi->param( 'assign_using' );
58 :     my $assign_using = ( $au =~ /^Sap/i ) ? 'Sapling' : 'SEED';
59 :     my @checked = $cgi->param( 'checked' );
60 :     my $color_aln_by = $cgi->param( 'color_aln_by' ) || 'consensus'; # consensus || residue
61 :     my $fid = $cgi->param( 'fid' ) || '';
62 :     my $from = $cgi->param( 'from' ) || ''; # assignment to propagate
63 :     my $rep_pegs = $cgi->param( 'rep_pegs' ) || 'all'; # all || roles || dlit || paralog
64 :     my $show_aliases = $cgi->param( 'show_aliases' ) || '';
65 :     my $show_align = $cgi->param( 'show_align' );
66 :     my $show_tree = $cgi->param( 'show_tree' );
67 :     my $tree_format = $cgi->param( 'tree_format' ); # default || newick || png
68 :     my $tree_id = $cgi->param( 'tree_id' );
69 : golsen 1.1
70 :     # Let's see if we can work out missing values from other data:
71 :    
72 :     $fid ||= $checked[0] if @checked == 1;
73 : golsen 1.3 $ali_tree_id ||= $align_id || $tree_id || '';
74 :     $ali_tree_id = '' if $action =~ /ali.* tree.* with.* prot/; # Forced update of list
75 :     if ( ( ! $ali_tree_id ) && ( ! @ali_tree_ids ) && $fid )
76 : golsen 1.1 {
77 : golsen 1.3 @ali_tree_ids = AlignsAndTreesServer::aligns_with_pegID( $sapObject, $fid );
78 : golsen 1.1 }
79 : golsen 1.3 $ali_tree_id ||= $ali_tree_ids[0] if @ali_tree_ids == 1;
80 : golsen 1.1
81 :     # Move alignment and tree selection information into one id and two booleans
82 :    
83 : golsen 1.3 $show_align ||= $align_id;
84 :     $show_tree ||= $tree_id;
85 :    
86 :     #------------------------------------------------------------------------------
87 :     # We have the analysis paramaters. Put them in a local hash so they can be passed to
88 :     # subroutines.
89 :     #------------------------------------------------------------------------------
90 :    
91 :     my $data = {};
92 :    
93 :     $data->{ fig } = $fig;
94 :     $data->{ sap } = $sapObject;
95 :     $data->{ cgi } = $cgi;
96 :     $data->{ html } = \@html;
97 :     $data->{ user } = $user;
98 :    
99 :     $data->{ action } = $action;
100 :     $data->{ ali_tree_id } = $ali_tree_id;
101 :     $data->{ ali_tree_ids } = \@ali_tree_ids;
102 :     $data->{ align_format } = $align_format;
103 :     $data->{ assign_using } = $assign_using;
104 :     $data->{ can_assign } = $user && ( $assign_using =~ /SEED/i );
105 :     $data->{ checked } = \@checked;
106 :     $data->{ color_aln_by } = $color_aln_by;
107 :     $data->{ fid } = $fid;
108 :     $data->{ from } = $from;
109 :     $data->{ rep_pegs } = $rep_pegs;
110 :     $data->{ show_aliases } = $show_aliases;
111 :     $data->{ show_align } = $show_align;
112 :     $data->{ show_tree } = $show_tree;
113 :     $data->{ tree_format } = $tree_format;
114 :    
115 :     #------------------------------------------------------------------------------
116 :     # Start the page:
117 :     #------------------------------------------------------------------------------
118 :    
119 :     page_head_html( $data );
120 :    
121 :    
122 :     #------------------------------------------------------------------------------
123 :     # Deal with assignments:
124 :     #------------------------------------------------------------------------------
125 :    
126 :     if ( $data->{ action } =~ /assign/i )
127 :     {
128 :     make_assignments( $data );
129 :     }
130 :    
131 :     #------------------------------------------------------------------------------
132 :     # Change the focus peg:
133 :     #------------------------------------------------------------------------------
134 :    
135 :     if ( $data->{ action } =~ /focus/i && $from )
136 :     {
137 :     $fid = $from;
138 :     }
139 :    
140 :     #------------------------------------------------------------------------------
141 :     # Start the form:
142 :     #------------------------------------------------------------------------------
143 :    
144 :     push @html, $cgi->start_form( -method => 'post',
145 :     -action => 'align_and_tree.cgi',
146 :     -name => 'alignment'
147 :     );
148 :    
149 :     #------------------------------------------------------------------------------
150 :     # Alignment and tree format controls:
151 :     #------------------------------------------------------------------------------
152 : golsen 1.1
153 : golsen 1.3 add_general_options( $data );
154 :    
155 :     #------------------------------------------------------------------------------
156 :     # Collect all of the necessary alignment and/or tree data:
157 :     #------------------------------------------------------------------------------
158 :    
159 :     if ( $data->{ ali_tree_id } && ( $data->{ show_align } || $data->{ show_tree } ) )
160 :     {
161 :     compile_alignment_and_tree_data( $data );
162 :     }
163 :    
164 :     #------------------------------------------------------------------------------
165 :     # Alignment dispaly
166 :     #------------------------------------------------------------------------------
167 :    
168 :     if ( $data->{ ali_tree_id } && $data->{ show_align } )
169 :     {
170 :     show_alignment( $data );
171 :     }
172 :    
173 :     #------------------------------------------------------------------------------
174 :     # Tree display
175 :     #------------------------------------------------------------------------------
176 :    
177 :     if ( $data->{ ali_tree_id } && $data->{ show_tree } )
178 :     {
179 :     show_tree( $data );
180 :     }
181 :    
182 :     #------------------------------------------------------------------------------
183 :     # Select alignments and trees with given fid
184 :     #------------------------------------------------------------------------------
185 :    
186 :     if ( ! $data->{ ali_tree_id } )
187 :     {
188 :     show_alignments_and_trees_with_fid( $data );
189 :     }
190 :    
191 :     #------------------------------------------------------------------------------
192 :     # Finish form and page
193 :     #------------------------------------------------------------------------------
194 :    
195 :     push @html, join( "\n",
196 :     $cgi->end_form,
197 :     $cgi->br,
198 :     '</BODY>',
199 :     '</HTML>',
200 :     ''
201 :     );
202 :    
203 :     #------------------------------------------------------------------------------
204 :     # Report the output
205 :     #------------------------------------------------------------------------------
206 :    
207 :     print join( '', @html, "\n" );
208 :     exit;
209 :    
210 :    
211 :     #==============================================================================
212 :     # Only subroutines below
213 :     #==============================================================================
214 :     # This is a sufficient set of escaping for text in HTML (function and alias):
215 :     #
216 :     # $html = html_esc( $text )
217 :     #------------------------------------------------------------------------------
218 :    
219 :     sub html_esc { local $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
220 : golsen 1.1
221 :    
222 : golsen 1.3 #===============================================================================
223 :     # Start the HTML
224 :     #===============================================================================
225 : golsen 1.1
226 : golsen 1.3 sub page_head_html
227 : golsen 1.1 {
228 : golsen 1.3 my ( $data ) = @_;
229 :     my $html = $data->{ html } || [];
230 :    
231 :     my $ali_tree_id = $data->{ ali_tree_id };
232 :     my $fid = $data->{ fid };
233 :     my $show_align = $data->{ show_align };
234 :     my $show_tree = $data->{ show_tree };
235 :    
236 :     my $title;
237 :     if ( $show_align && $ali_tree_id )
238 : golsen 1.1 {
239 : golsen 1.3 if ( $show_tree ) { $title = "The SEED: Protein Alignment $ali_tree_id" }
240 :     else { $title = "The SEED: Protein Alignment and Tree $ali_tree_id" }
241 :     }
242 :     elsif ( $show_tree && $ali_tree_id )
243 :     {
244 :     $title = "The SEED: Protein Tree $ali_tree_id";
245 : golsen 1.1 }
246 :     else
247 :     {
248 : golsen 1.3 if ( $fid ) { $title = "The SEED: Protein Alignment and Tree Selector for '$fid'" }
249 :     else { $title = "The SEED: Protein Alignment and Tree Selector" }
250 :     }
251 :    
252 :     # This stuff is because different browsers render the contents differently.
253 :    
254 :     my $agent = $ENV{ HTTP_USER_AGENT } || '';
255 :     my $height = $agent =~ /Safari/i ? '110%'
256 :     : $agent =~ /Firefox/i ? '100%'
257 :     : '100%';
258 :     my $lsize = $agent =~ /Safari/i ? '160%'
259 :     : $agent =~ /Firefox/i ? '130%'
260 :     : '140%';
261 :    
262 :     push @$html, <<"End_of_Head";
263 :     <HTML>
264 :     <HEAD>
265 :     <TITLE>$title</TITLE>
266 :    
267 :     <STYLE Type="text/css">
268 :     /* Support for HTML printer graphics tree */
269 :     DIV.tree {
270 :     border-spacing: 0px;
271 :     font-size: 100%;
272 :     line-height: $height;
273 :     white-space: nowrap;
274 :     }
275 :     DIV.tree A {
276 :     text-decoration: none;
277 :     }
278 :     DIV.tree PRE {
279 :     padding: 0px;
280 :     margin: 0px;
281 :     font-size: $lsize;
282 :     display: inline;
283 :     }
284 :     DIV.tree INPUT {
285 :     padding: 0px;
286 :     margin: 0px;
287 :     height: 10px; /* ignored by Firefox */
288 :     width: 10px; /* ignored by Firefox */
289 :     }
290 :     DIV.tree SPAN.w { /* used for tree white space */
291 :     color: white;
292 :     }
293 :     </STYLE>
294 :    
295 :     </HEAD>
296 :     <BODY>
297 :     End_of_Head
298 :    
299 :     return @$html if wantarray;
300 :     }
301 :    
302 :    
303 :     #===============================================================================
304 :     # Make requested assignments.
305 :     #===============================================================================
306 :    
307 :     sub make_assignments
308 :     {
309 :     my ( $data ) = @_;
310 :    
311 :     my $fig = $data->{ fig };
312 :     my $sap = $data->{ sap };
313 :     my $cgi = $data->{ cgi };
314 :     my $html = $data->{ html };
315 :     my $user = $data->{ user };
316 :     my $from = $data->{ from };
317 :    
318 :     my $func;
319 :     if ( defined( $from ) && ( $func = $fig->function_of( $from, $user ) ) && @{ $data->{ checked } } )
320 :     {
321 :     $func =~ s/\s+\#[^\#].*$//; # Remove single hash comments
322 :     # We now expand the pegs to all pegs with the same md5:
323 :     my $pegs_to_md5 = AlignsAndTreesServer::pegs_to_md5( $sap, @{ $data->{ checked } } );
324 :    
325 :     #***********************************************************************
326 :     # Note: values %$pegs_to_md5 may include values that you do not want!!!
327 :     #***********************************************************************
328 :     my %seen_md5;
329 :     my @md5s = grep { ! $seen_md5{ $_ }++ }
330 :     map { $pegs_to_md5->{ $_ } }
331 :     @{ $data->{ checked } };
332 :     my $md5s_to_pegs = AlignsAndTreesServer::md5s_to_pegs( $sap, @md5s );
333 :    
334 :     #***********************************************************************
335 :     # Note: values %$md5s_to_pegs may include values that you do not want!!!
336 :     #***********************************************************************
337 :     my %seen_peg = ( $from => 1 ); # Skip self assignment
338 :     my @pegs = grep { ! $seen_peg{ $_ }++ }
339 :     map { @{ $md5s_to_pegs->{ $_ } || [] } }
340 :     @md5s;
341 :    
342 :     if ( $data->{ assign_using } =~ /SEED/i && $fig )
343 :     {
344 :     my ( $nsucc, $nfail );
345 :     foreach my $peg ( @pegs )
346 :     {
347 :     if ( $fig->assign_function( $peg, $user, $func, "" ) )
348 :     {
349 :     $fig->add_annotation( $peg, $user, "Assigned based on tree proximity to $from\n" );
350 :     $nsucc++;
351 :     }
352 :     else
353 :     {
354 :     $nfail++;
355 :     }
356 :     }
357 :     push @$html, $cgi->h3( "$nsucc protein assignments made." ) if $nsucc;
358 :     push @$html, $cgi->h3( "$nfail attemped protein assignments ignored." ) if $nfail;
359 :     }
360 : golsen 1.1 }
361 :     }
362 : golsen 1.3
363 :    
364 :     #===============================================================================
365 :     # Push the general page options into the html.
366 :     #===============================================================================
367 :    
368 :     sub add_general_options
369 : golsen 1.1 {
370 : golsen 1.3 my ( $data ) = @_;
371 :     my $cgi = $data->{ cgi };
372 :     my $html = $data->{ html } || [];
373 :    
374 :     if ( @{ $data->{ checked } } && ! $data->{ show_tree } )
375 : golsen 1.1 {
376 : golsen 1.3 push @$html, $cgi->hidden( -name => 'checked', -value => $data->{ checked } );
377 : golsen 1.1 }
378 : golsen 1.3
379 :     if ( $data->{ ali_tree_id } )
380 : golsen 1.1 {
381 : golsen 1.3 push @$html, $cgi->hidden( -name => 'ali_tree_id', -value => $data->{ ali_tree_id } );
382 :     }
383 :    
384 :     push @$html, 'SEED user: ',
385 :     $cgi->textfield( -name => "user", -value => $user, -size => 32 ),
386 :     $cgi->br;
387 :    
388 :     if ( $data->{ ali_tree_id } || $data->{ fid } )
389 :     {
390 :     push @$html, 'Focus protein ID? ';
391 : golsen 1.1 }
392 :     else
393 :     {
394 : golsen 1.3 push @$html, $cgi->h2( 'Enter a SEED protein id: ' );
395 : golsen 1.1 }
396 :    
397 : golsen 1.3 push @$html, $cgi->textfield( -name => "fid", -size => 32, -value => $data->{ fid } ),
398 :     $cgi->submit( -name => 'action', -value => 'list all alignments and trees with this protein' ),
399 :     $cgi->br;
400 :    
401 :     if ( ! $data->{ show_align } && ! $data->{ show_tree } )
402 :     {
403 :     push @$html, $cgi->h2( 'Neither alignment nor tree are selected below. Please select at least one.' );
404 :     }
405 :    
406 :     push @$html, $cgi->checkbox( -name => 'show_align',
407 :     -label => 'Show alignment',
408 :     -override => 1,
409 :     -checked => $data->{ show_align }
410 :     ),
411 :     '&nbsp;',
412 :     $cgi->checkbox( -name => 'show_tree',
413 :     -label => 'Show tree',
414 :     -override => 1,
415 :     -checked => $data->{ show_tree }
416 :     ),
417 :     $cgi->br, $cgi->br;
418 :    
419 :     if ( $user )
420 :     {
421 :     push @$html, 'Use for functions and assignments: ',
422 :     $cgi->radio_group( -name => 'assign_using',
423 :     -override => 1,
424 :     -values => [ 'Sapling', 'SEED' ],
425 :     -default => $data->{ assign_using }
426 :     ),
427 :     $cgi->br;
428 :     }
429 :    
430 :     push @$html, $cgi->br,
431 :     'Color alignment by: ',
432 :     $cgi->radio_group( -name => 'color_aln_by',
433 :     -override => 1,
434 :     -values => [ 'consensus', 'residue' ],
435 :     -default => $data->{ color_aln_by }
436 :     ),
437 :     $cgi->br;
438 : golsen 1.1
439 : golsen 1.3 push @$html, 'Alignment format: ',
440 :     $cgi->radio_group( -name => 'align_format',
441 :     -override => 1,
442 :     -values => [ 'default', 'fasta', 'clustal' ],
443 :     -default => $data->{ align_format } || 'default'
444 : golsen 1.1 ),
445 : golsen 1.3 $cgi->br, $cgi->br;
446 : golsen 1.1
447 : golsen 1.3 push @$html, 'Tree format: ',
448 :     $cgi->radio_group( -name => 'tree_format',
449 :     -override => 1,
450 :     -values => [ 'default', 'newick', 'png' ],
451 :     -default => $data->{ tree_format } || 'default'
452 :     ),
453 :     $cgi->br;
454 : golsen 1.1
455 : golsen 1.3 push @$html, $cgi->checkbox( -name => 'show_aliases',
456 :     -label => 'Show aliases in tree',
457 :     -override => 1,
458 :     -checked => $data->{ show_aliases }
459 :     ),
460 :     $cgi->br, $cgi->br;
461 : golsen 1.1
462 : golsen 1.3 push @$html, $cgi->submit( -name => 'action', -value => 'update' ),
463 :     $cgi->br;
464 : golsen 1.1
465 : golsen 1.3 return @$html if wantarray;
466 :     }
467 : golsen 1.1
468 :    
469 :     #------------------------------------------------------------------------------
470 : golsen 1.3 # Compile all necessary data for alignments and trees.
471 : golsen 1.1 # The per sequence metadata are:
472 :     #
473 :     # [ $peg_id, $peg_length, $trim_beg, $trim_end, $location_string ]
474 :     #
475 :     #------------------------------------------------------------------------------
476 :    
477 : golsen 1.3 sub compile_alignment_and_tree_data
478 : golsen 1.1 {
479 : golsen 1.3 my ( $data ) = @_;
480 :    
481 :     ( $data->{ ali_tree_id } && ( $data->{ show_align } || $data->{ show_tree } ) )
482 :     or return 0;
483 :    
484 :     my $html = $data->{ html } || [];
485 :     my $sap = $data->{ sap };
486 :    
487 :     my $align = [];
488 :     my $tree = undef;
489 :     my $metaH = {};
490 :    
491 :     if ( $data->{ show_align } )
492 :     {
493 :     ( $align, $metaH ) = AlignsAndTreesServer::peg_alignment_by_ID( $data->{ ali_tree_id } );
494 :     }
495 :     if ( $data->{ show_tree } )
496 : golsen 1.2 {
497 : golsen 1.3 ( $tree, $metaH ) = AlignsAndTreesServer::peg_tree_by_ID( $data->{ ali_tree_id } );
498 : golsen 1.2 }
499 : golsen 1.3
500 :     $metaH && %$metaH
501 :     or push @$html, $cgi->h2( "No data for alignment and tree '$data->{ali_tree_id}'." );
502 :    
503 :     my @uids = keys %$metaH; # Ids of alignment line and tree tips
504 :     my %fid_of_uid = map { $_ => $metaH->{$_}->[0] } @uids;
505 :    
506 :     my %peg_seen = {};
507 :     my @fids = grep { ! $peg_seen{$_}++ } values %fid_of_uid;
508 :    
509 :     #--------------------------------------------------------------------------
510 :     # Find the current functions and organism names:
511 :     #--------------------------------------------------------------------------
512 :    
513 :     my $fid_funcH = {};
514 :     my $orgH = {};
515 :     if ( @fids && $data->{ assign_using } =~ /^SEED/i && $fig )
516 : golsen 1.2 {
517 : golsen 1.3 foreach my $peg ( @fids )
518 :     {
519 :     $fid_funcH->{ $peg } = $fig->function_of( $peg, $user ) || "";
520 :     $orgH->{ $peg } = $fig->org_of( $peg );
521 :     }
522 : golsen 1.2 }
523 : golsen 1.3 elsif ( @fids )
524 : golsen 1.2 {
525 : golsen 1.3 $sap ||= SAPserver->new();
526 :     $fid_funcH = $sap->ids_to_functions( -ids => \@fids ) || {};
527 :     $orgH = $sap->ids_to_genomes( -ids => \@fids, -name => 1 ) || {};
528 : golsen 1.2 }
529 :    
530 : golsen 1.3 #--------------------------------------------------------------------------
531 :     # Aliases
532 :     #--------------------------------------------------------------------------
533 : golsen 1.1
534 : golsen 1.3 my $aliasH = {};
535 :     if ( $data->{ show_aliases } ) { 0 }
536 : golsen 1.1
537 : golsen 1.3 #--------------------------------------------------------------------------
538 :     # dlits
539 :     #--------------------------------------------------------------------------
540 :    
541 :     my $dlitH = $sap->dlits_for_ids( -ids => \@fids );
542 : golsen 1.1
543 :     #--------------------------------------------------------------------------
544 : golsen 1.3 # Projections from peg of md5a:
545 :     #
546 :     # [ $n_shared, $identity, $score ]
547 : golsen 1.1 #--------------------------------------------------------------------------
548 :    
549 : golsen 1.3 # Get the projections
550 :     my $md5 = AlignsAndTreesServer::peg_to_md5( $sap, $fid ) || '';
551 :     my $projH = AlignsAndTreesServer::get_md5_projections( $md5, { details => 1 } ) || {};
552 :     my @projs = @{ $projH->{ $md5 } || [] };
553 :    
554 :     # Expend the md5 values
555 :     my @proj_md5s = map { $_->[0] } @projs;
556 :     my $md5_to_pegs = AlignsAndTreesServer::md5s_to_pegs( $sap, $md5, @proj_md5s );
557 :    
558 :     # Expand the projections
559 :     my ( $proj, $md5b, @pegs );
560 :     my %projection;
561 :     foreach $proj ( @projs )
562 :     {
563 :     $md5b = $proj->[0];
564 :     @pegs = @{ $md5_to_pegs->{ $md5b } || [] };
565 :     foreach ( @pegs ) { $projection{ $_ } = [ @$proj[ 1 .. 3 ] ] }
566 :     }
567 :    
568 :     # Projections to identical sequences
569 :     @pegs = @{ $md5_to_pegs->{ $md5 } || [] };
570 :     foreach ( @pegs ) { $projection{ $_ } = [ 10, 100, 1 ] }
571 : golsen 1.1
572 :     #--------------------------------------------------------------------------
573 : golsen 1.3 # Put in data hash
574 : golsen 1.1 #--------------------------------------------------------------------------
575 :    
576 : golsen 1.3 $data->{ alias } = $aliasH;
577 :     $data->{ align } = $align;
578 :     $data->{ dlits } = $dlitH;
579 :     $data->{ fid_func } = $fid_funcH;
580 :     $data->{ fid_of_uid } = \%fid_of_uid;
581 :     $data->{ fids } = \@fids;
582 :     $data->{ org } = $orgH;
583 :     $data->{ projects } = \%projection;
584 :     $data->{ seq_meta } = $metaH;
585 :     $data->{ tree } = $tree;
586 :     $data->{ uids } = \@uids;
587 : golsen 1.1
588 : golsen 1.3 return @$html if wantarray;
589 : golsen 1.1 }
590 :    
591 :    
592 :     #==============================================================================
593 : golsen 1.3 # Show an alignment
594 : golsen 1.1 #==============================================================================
595 :    
596 : golsen 1.3 sub show_alignment
597 : golsen 1.1 {
598 : golsen 1.3 my ( $data ) = @_;
599 :     my $html = $data->{ html } || [];
600 :    
601 :     ( $data->{ ali_tree_id } && $data->{ show_align } ) or return;
602 :    
603 :     my $align = $data->{ align };
604 : golsen 1.1 $align && @$align
605 : golsen 1.3 or push @$html, $cgi->h2( "No data for alignment '$data->{ali_tree_id}'." );
606 : golsen 1.1
607 :     # This defines the ordering.
608 :     my @seq_ids = map { $_->[0] } @$align;
609 :    
610 : golsen 1.3 push @$html, $cgi->h2( "Alignment $data->{ali_tree_id}" ) . "\n";
611 :    
612 :     my $fid_of_uid = $data->{ fid_of_uid };
613 :     my $fid_func = $data->{ fid_func };
614 :     my $org = $data->{ org };
615 : golsen 1.1
616 : golsen 1.3 if ( $align && @$align && ( $data->{ align_format } =~ /^fasta/i ) )
617 : golsen 1.1 {
618 :     my ( $id, $peg );
619 :     my %def = map { $id = $_->[0];
620 : golsen 1.3 $peg = $fid_of_uid->{ $id };
621 : golsen 1.1 $id => join( ' ', $id,
622 : golsen 1.3 ( $fid_func->{ $id } ? $fid_func->{$id} : () ),
623 :     ( $org->{ $id } ? "[$org->{$id}]" : () )
624 : golsen 1.1 )
625 :     }
626 :     @$align;
627 : golsen 1.2
628 : golsen 1.3 push @$html, join( "\n",
629 : golsen 1.1 "<PRE>",
630 :     ( map { ( ">$def{$_->[0]}", $_->[2] =~ m/(.{1,60})/g ) } @$align ),
631 :     "</PRE>\n"
632 :     );
633 :     }
634 :    
635 : golsen 1.3 elsif ( $align && @$align && ( $data->{ align_format } =~ /^clustal/i ) )
636 : golsen 1.1 {
637 : golsen 1.3 push @$html, "<PRE>\n", &to_clustal( $align ), "</PRE>\n";
638 : golsen 1.1 }
639 :    
640 :     elsif ( $align && @$align )
641 :     {
642 :     my ( $align2, $legend );
643 :    
644 :     # Color by residue type:
645 :    
646 : golsen 1.3 if ( $data->{ color_aln_by } eq 'residue' )
647 : golsen 1.1 {
648 :     my %param1 = ( align => $align, protein => 1 );
649 :     $align2 = gjoalign2html::color_alignment_by_residue( \%param1 );
650 :     }
651 :    
652 :     # Color by consensus:
653 :    
654 :     else
655 :     {
656 :     my %param1 = ( align => $align );
657 :     ( $align2, $legend ) = gjoalign2html::color_alignment_by_consensus( \%param1 );
658 :     }
659 :    
660 :     # Add organism names:
661 :    
662 : golsen 1.3 foreach ( @$align2 ) { $_->[1] = $org->{ $_->[0] || '' } }
663 : golsen 1.1
664 :     # Build a tool tip with organism names and functions:
665 :    
666 : golsen 1.3 my %tips = map { $_ => [ $_, join( $cgi->hr, $org->{ $_ }, $fid_func->{ $_ } ) ] }
667 : golsen 1.2 map { $_->[0] }
668 :     @$align2;
669 : golsen 1.1 $tips{ 'Consen1' } = [ 'Consen1', 'Primary consensus residue' ];
670 :     $tips{ 'Consen2' } = [ 'Consen2', 'Secondary consensus residue' ];
671 :    
672 :     my %param2 = ( align => $align2,
673 :     tooltip => \%tips
674 :     );
675 : golsen 1.2 $param2{ legend } = $legend if $legend;
676 : golsen 1.1
677 : golsen 1.3 push @$html, join( "\n",
678 : golsen 1.1 scalar gjoalign2html::alignment_2_html_table( \%param2 ),
679 :     $cgi->br,
680 :     );
681 :     }
682 : golsen 1.3
683 :     return @$html if wantarray;
684 :     }
685 :    
686 :    
687 :     #------------------------------------------------------------------------------
688 :     # Clustal format alignment
689 :     #------------------------------------------------------------------------------
690 :     sub to_clustal
691 :     {
692 :     my( $alignment ) = @_;
693 :    
694 :     my($tuple,$seq,$i);
695 :     my $len_name = 0;
696 :     foreach $tuple ( @$alignment )
697 :     {
698 :     my $sz = length( $tuple->[0] );
699 :     $len_name = ($sz > $len_name) ? $sz : $len_name;
700 :     }
701 :    
702 :     my @seq = map { $_->[2] } @$alignment;
703 :     my $seq1 = shift @seq;
704 :     my $cons = "\377" x length($seq1);
705 :     foreach $seq (@seq)
706 :     {
707 :     $seq = ~($seq ^ $seq1);
708 :     $seq =~ tr/\377/\000/c;
709 :     $cons &= $seq;
710 :     }
711 :     $cons =~ tr/\000/ /;
712 :     $cons =~ tr/\377/*/;
713 :    
714 :     push(@$alignment,["","",$cons]);
715 :    
716 :     my @out = ();
717 :     for ($i=0; ($i < length($seq1)); $i += 50)
718 :     {
719 :     foreach $tuple (@$alignment)
720 :     {
721 :     my($id,undef,$seq) = @$tuple;
722 :     my $line = sprintf("\%-${len_name}s %s\n", $id, substr($seq,$i,50));
723 :     push(@out,$line);
724 :     }
725 :     push(@out,"\n");
726 :     }
727 :     return join("","CLUSTAL W (1.8.3) multiple sequence alignment\n\n\n",@out);
728 : golsen 1.1 }
729 :    
730 :    
731 :     #==============================================================================
732 :     # Tree:
733 :     #==============================================================================
734 :    
735 : golsen 1.3 sub show_tree
736 : golsen 1.1 {
737 : golsen 1.3 my ( $data ) = @_;
738 : golsen 1.1
739 : golsen 1.3 my $html = $data->{ html } || [];
740 :    
741 :     my $tree = $data->{ tree };
742 :     if ( ! $tree )
743 :     {
744 :     push @$html, $cgi->h2( "No data for tree '$data->{ali_tree_id}'." );
745 :     return wantarray ? @$html : ();
746 :     }
747 :    
748 :     push @$html, $cgi->h2( "Tree $data->{ali_tree_id}" ) . "\n" if $tree;
749 :    
750 :     my $can_assign = $data->{ can_assign };
751 :     my $fid_of_uid = $data->{ fid_of_uid };
752 :     my $fid_func = $data->{ fid_func } || {};
753 :     my $org = $data->{ org } || {};
754 :     my $alias = $data->{ alias } || {};
755 :     my $dlits = $data->{ dlits } || {};
756 :     my $proj = $data->{ projects } || {};
757 : golsen 1.1
758 :     #------------------------------------------------------------------
759 :     # Newick tree
760 :     #------------------------------------------------------------------
761 : golsen 1.3 if ( $tree && ( $data->{ tree_format } =~ /^newick/i ) )
762 : golsen 1.1 {
763 : golsen 1.3 push @$html, "<pre>\n" . &gjonewicklib::formatNewickTree( $tree ) . "</pre>\n";
764 : golsen 1.1 }
765 :    
766 :     #------------------------------------------------------------------
767 :     # PNG tree
768 :     #------------------------------------------------------------------
769 : golsen 1.3 elsif ( $tree && ( $data->{ tree_format } =~ /^png/i ) )
770 : golsen 1.1 {
771 :     my $okay;
772 :     eval { require gd_tree_0; $okay = 1 };
773 :     my $fmt;
774 :     if ( $okay && ( $fmt = ( gd_tree::gd_has_png() ? 'png' :
775 :     gd_tree::gd_has_jpg() ? 'jpeg' :
776 :     undef
777 :     ) ) )
778 :     {
779 :     #------------------------------------------------------------------
780 :     # Formulate the desired labels
781 :     #------------------------------------------------------------------
782 :     my %labels;
783 : golsen 1.3 foreach my $id ( @{ $data->{ uids } } )
784 : golsen 1.1 {
785 : golsen 1.3 my $peg = $fid_of_uid->{ $id };
786 : golsen 1.1 my @label;
787 :     push @label, $id;
788 : golsen 1.3 push @label, $fid_func->{ $peg } if $fid_func->{ $peg };
789 :     push @label, "[$org->{$peg}]" if $org->{ $peg };
790 :     push @label, html_esc( $alias->{ $peg } ) if $alias->{ $peg };
791 : golsen 1.1
792 :     $labels{ $id } = join( ' ', @label );
793 :     }
794 : golsen 1.2
795 : golsen 1.1 #------------------------------------------------------------------
796 :     # Relabel the tips, midpoint root, pretty it up and draw
797 :     # the tree as printer plot
798 :     #
799 :     # Adjustable parameters on text_plot_newick:
800 :     #
801 :     # @lines = text_plot_newick( $node, $width, $min_dx, $dy )
802 :     #------------------------------------------------------------------
803 :     my $tree2 = newick_relabel_nodes( $tree, \%labels );
804 :     my $tree3 = reroot_newick_to_midpoint_w( $tree2 );
805 :    
806 :     $tree = aesthetic_newick_tree( $tree3 );
807 :     my $options = { thickness => 2,
808 :     dy => 15,
809 :     };
810 :     my $gd = gd_tree::gd_plot_newick( $tree, $options );
811 :    
812 :     my $name = sprintf( "align_and_tree_%d_%08d.$fmt", $$, int(1e8*rand()) );
813 :     my $file = "$FIG_Config::temp/$name";
814 :     open TREE, ">$file";
815 :     binmode TREE;
816 :     print TREE $gd->$fmt;
817 :     close TREE;
818 :     chmod 0644, $file;
819 :    
820 :     my $url = &FIG::temp_url() . "/$name";
821 : golsen 1.3 push @$html, $cgi->br . "\n"
822 : golsen 1.1 . "<img src='$url' border=0>\n"
823 :     . $cgi->br . "\n";
824 :     }
825 :     else
826 :     {
827 : golsen 1.3 push @$html, "<h3>Failed to convert tree to PNG. Sorry.</h3>\n"
828 : golsen 1.1 . "<h3>Please choose another format above.</h3>\n";
829 :     }
830 :     }
831 :    
832 :     #------------------------------------------------------------------
833 :     # Printer plot tree
834 :     #------------------------------------------------------------------
835 :     else
836 :     {
837 :     #------------------------------------------------------------------
838 :     # Formulate the desired labels:
839 :     #------------------------------------------------------------------
840 : golsen 1.2 # Build a function-to-color translation table based on frequency of
841 :     # function. Normally white is reserved for the current function, but
842 :     # there is none here. Assign colors until we run out, then go gray.
843 :     # Undefined function is not in %func_color, and so is not in
844 :     # %formatted_func
845 :     #----------------------------------------------------------------------
846 : golsen 1.3 my %formatted_func = &FIGgjo::colorize_roles( $fid_func );
847 : golsen 1.2
848 : golsen 1.1 my %labels;
849 : golsen 1.3 foreach my $id ( @{ $data->{ uids } } )
850 : golsen 1.1 {
851 : golsen 1.3 my $peg = $fid_of_uid->{ $id };
852 :     my $func = $fid_func->{ $peg };
853 :     my $functext = $func ? $formatted_func{ $func } : '';
854 :     my $orgname = $org->{ $peg } ? html_esc( $org->{ $peg } ) : '';
855 :     my $proj_scr = $proj->{ $peg } ? $proj->{ $peg }->[2] : 0;
856 :     my $hbar = score_to_hbar( $proj_scr );
857 :    
858 :     if ( $dlits->{$peg} && @{$dlits->{$peg}} )
859 :     {
860 :     $functext = qq(<SPAN Style='font-weight:bold'>$functext</SPAN>) if $functext;
861 :     $orgname = qq(<SPAN Style='font-weight:bold'>$orgname</SPAN>) if $orgname;
862 :     }
863 :    
864 : golsen 1.1 my @label;
865 :     push @label, &HTML::fid_link( $cgi, $peg ) . '&nbsp;';
866 : golsen 1.3 push @label, qq(<INPUT Type=checkbox Name=checked Value="$peg">) if $can_assign && $orgname;
867 :     push @label, qq(<INPUT Type=radio Name=from Value="$peg">) if $func;
868 :     push @label, $hbar;
869 :     push @label, $functext if $functext;
870 :     push @label, "[$orgname]" if $orgname;
871 :     push @label, html_esc( $alias->{ $peg } ) if $alias->{ $peg };
872 : golsen 1.1
873 : golsen 1.2 $labels{ $id } = join( ' ', @label );
874 : golsen 1.1 }
875 :    
876 :     #------------------------------------------------------------------
877 :     # Relabel the tips, midpoint root, and pretty it up.
878 :     #------------------------------------------------------------------
879 :    
880 :     my $tree2 = newick_relabel_nodes( $tree, \%labels );
881 :     my $tree3 = reroot_newick_to_midpoint_w( $tree2 );
882 :     $tree = aesthetic_newick_tree( $tree3 );
883 :    
884 :     #------------------------------------------------------------------
885 :     # Form and JavaScript added by RAE, 2004-Jul-22, 2004-Aug-23.
886 :     # Modified by GDP to make it DWWM, 2004-Jul-23, 2004-Aug-04.
887 :     #------------------------------------------------------------------
888 :    
889 : golsen 1.3 push @$html, join( "\n",
890 : golsen 1.1 $cgi->start_form( -method => 'post',
891 :     -target => '_blank',
892 :     -action => 'fid_checked.cgi',
893 :     -name => 'protein_tree'
894 :     ),
895 : golsen 1.3 $cgi->hidden( -name => 'align_format', -value => $data->{ align_format } ),
896 :     $cgi->hidden( -name => 'color_aln_by', -value => $data->{ color_aln_by } ),
897 :     $cgi->hidden( -name => 'fid', -value => $data->{ fid } ),
898 :     $cgi->hidden( -name => 'show_aliases', -value => $data->{ show_aliases } ),
899 :     $cgi->hidden( -name => 'tree_format', -value => $data->{ tree_format } ),
900 : golsen 1.1 $cgi->hidden( -name => 'user', -value => $user ),
901 :     ""
902 :     );
903 :    
904 :     #------------------------------------------------------------------
905 :     # Draw the tree as printer plot.
906 :     #------------------------------------------------------------------
907 :    
908 : golsen 1.3 if ( $user )
909 :     {
910 :     push @$html, $cgi->submit( -name => 'action', -value => 'assign' );
911 :     }
912 :     push @$html, $cgi->submit( -name => 'action', -value => 'chnage focus peg' ),
913 :     $cgi->br;
914 :    
915 : golsen 1.1 my $plot_options = { chars => 'html', # html-encoded unicode box set
916 :     format => 'tree_lbl', # line = [ $graphic, $label ]
917 :     dy => 1,
918 :     min_dx => 1,
919 :     width => 64
920 :     };
921 : golsen 1.3 push @$html, join( "\n",
922 : golsen 1.1 '',
923 :     '<DIV Class="tree">',
924 :     ( map { my ( $line, $lbl ) = @$_;
925 :     # Fix white space for even spacing:
926 :     $line =~ s/((&nbsp;)+)/<SPAN Class=w>$1<\/SPAN>/g;
927 :     $line =~ s/&nbsp;/&#9474;/g;
928 :     # Output line, with or without label:
929 :     $lbl ? "<PRE>$line</PRE> $lbl<BR />"
930 :     : "<PRE>$line</PRE><BR />"
931 :     }
932 :     gjonewicklib::text_plot_newick( $tree, $plot_options )
933 :     ),
934 :     '</DIV>',
935 :     '', ''
936 :     );
937 :    
938 : golsen 1.3 push @$html, join ("\n", $cgi->br, &HTML::java_buttons( "protein_tree", "checked" ), $cgi->br, "");
939 : golsen 1.1
940 :     if ( $user )
941 :     {
942 : golsen 1.3 push @$html, $cgi->submit( -name => 'action', -value => 'assign' );
943 :     }
944 : golsen 1.1
945 : golsen 1.3 push @$html, $cgi->submit( -name => 'action', -value => 'chnage focus peg' ),
946 :     $cgi->br;
947 : golsen 1.1
948 : golsen 1.3 push @$html, $cgi->end_form;
949 : golsen 1.1 }
950 :    
951 : golsen 1.3 return @$html if wantarray;
952 : golsen 1.1 }
953 :    
954 : golsen 1.3
955 : golsen 1.1 #==============================================================================
956 : golsen 1.3 # Select alignments and trees with given fid
957 : golsen 1.1 #==============================================================================
958 :    
959 : golsen 1.3 sub show_alignments_and_trees_with_fid
960 : golsen 1.1 {
961 : golsen 1.3 my ( $data ) = @_;
962 :     my $html = $data->{ html } || [];
963 :     my $sap = $data->{ sap };
964 :    
965 :     if ( @{ $data->{ ali_tree_ids } } )
966 :     {
967 :     push @$html, $cgi->h2( "Select an Alignment and/or Tree" ),
968 :     '<TABLE>',
969 :     '<TR><TH>ID</TH><TH>Count</TH><TH>Role</TH><TR>',
970 :     '<TABLEBODY>';
971 :     foreach my $id ( @{ $data->{ ali_tree_ids } } )
972 :     {
973 :     push @$html, '<TR><TD ColSpan=3><HR /></TD></TR>';
974 : golsen 1.1
975 : golsen 1.3 my @role_data = AlignsAndTreesServer::roles_in_align( $sap, $id );
976 :     splice @role_data, 5 if @role_data > 5;
977 :     my $nrow = @role_data;
978 :     my ( $role, $cnt ) = @{ shift @role_data };
979 :     $role = html_esc( $role );
980 :     push @$html, "<TR><TD RowSpan=$nrow><INPUT Type=radio Name=ali_tree_id Value=$id /> $id</TD>";
981 :     push @$html, " <TD Style='text-align:right'>$cnt</TD>";
982 :     push @$html, " <TD>$role</TD>";
983 :     push @$html, "</TR>";
984 :     foreach ( @role_data )
985 :     {
986 :     ( $role, $cnt ) = @$_;
987 :     $role = html_esc( $role );
988 :     push @$html, "<TR>";
989 :     push @$html, " <TD Style='text-align:right'>$cnt</TD>";
990 :     push @$html, " <TD>$role</TD>";
991 :     push @$html, "</TR>";
992 :     }
993 :     }
994 :     push @$html, '</TABLEBODY>',
995 :     '</TABLE>', $cgi->br,
996 :     $cgi->submit( -name => 'action', -value => 'update' ),
997 :     $cgi->br;
998 : golsen 1.1 }
999 : golsen 1.3 elsif ( $data->{ fid } )
1000 : golsen 1.1 {
1001 : golsen 1.3 @{ $data->{ ali_tree_ids } } = AlignsAndTreesServer::aligns_with_pegID( $sap, $data->{ fid } );
1002 :     push @$html, "Sorry, no alignments with protein id '$data->{fid}'\n<BR /><BR />\n" if ! @{ $data->{ ali_tree_ids } };
1003 :     }
1004 : golsen 1.1
1005 : golsen 1.3 return @$html if wantarray;
1006 : golsen 1.1 }
1007 :    
1008 :    
1009 : golsen 1.3 # Vertical and horizontal histogram bar graphics characters:
1010 :     #
1011 :     # 9601-9608
1012 :     # 9615-9608
1013 : golsen 1.1 #
1014 : golsen 1.3 sub score_to_vbar
1015 : golsen 1.1 {
1016 : golsen 1.3 my ($scr) = @_;
1017 :     my $code = int(($scr ** 0.8) / 0.15) + 9601;
1018 :     return "&#$code";
1019 : golsen 1.1 }
1020 :    
1021 :    
1022 : golsen 1.3 sub score_to_hbar
1023 : golsen 1.1 {
1024 : golsen 1.3 my ($scr) = @_;
1025 :     return '&nbsp;&nbsp;' if $scr == 0;
1026 :     my $code = 9615 - int( 7.999 * ($scr ** 1.00) );
1027 :     return "&#$code";
1028 :     }
1029 : golsen 1.1
1030 :    
1031 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3