[Bio] / FigKernelPackages / gjoalign2html.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/gjoalign2html.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (view) (download) (as text)

1 : fangfang 1.5 # This is a SAS component
2 :     #
3 :     # Copyright (c) 2003-2010 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 : golsen 1.1 package gjoalign2html;
20 :    
21 :     use strict;
22 :    
23 :     # Use FIGjs.pm if available:
24 :    
25 :     my $have_FIGjs = eval { require FIGjs; 1 };
26 :    
27 :     eval { use Data::Dumper }; # Not in all installations
28 :    
29 : golsen 1.2 #-------------------------------------------------------------------------------
30 :     # Prepend and/or append unaligned sequence data to a trimmed alignment:
31 :     #
32 :     # \@align = add_alignment_context( \@align, \@seqs, \%options )
33 :     #
34 :     # ( \@align, $pre_len, $ali_len, $suf_len )
35 :     # = add_alignment_context( \@align, \@seqs, \%options )
36 :     #
37 :     # Options:
38 :     #
39 :     # max_prefix => $limit # limit of residues to be added at beginning
40 :     # max_suffix => $limit # limit of residues to be added at end
41 :     # pad_char => $char # character to pad beginning and end (D = ' ')
42 :     #
43 :     #-------------------------------------------------------------------------------
44 :     # Change the pad character at the ends of an alignment:
45 :     #
46 :     # \@align = repad_alignment( \@align, \%options )
47 :     # \@align = repad_alignment( \%options )
48 :     # @align = repad_alignment( \@align, \%options )
49 :     # @align = repad_alignment( \%options )
50 :     #
51 :     # Options:
52 :     #
53 :     # pad_char => $char # character to pad beginning and end (D = ' ')
54 :     # old_pad => $regexp # characters to replace at end (D = [^A-Za-z.*])
55 :     #
56 :     #-------------------------------------------------------------------------------
57 :     # Color an alignment by residue type
58 :     #
59 :     # \@align = color_alignment_by_residue( \@align, \%options )
60 :     # \@align = color_alignment_by_residue( \%options )
61 :     # ( \@align, \@legend ) = color_alignment_by_residue( \@align, \%options )
62 :     # ( \@align, \@legend ) = color_alignment_by_residue( \%options )
63 :     #
64 :     # Options:
65 :     #
66 :     # align => \@alignment # alignment if not supplied as parameter
67 :     # alignment => \@alignment # alignment if not supplied as parameter
68 :     # colors => \%colors # character colors (html spec.)
69 :     # pallet => $pallet # ale | gde | default
70 :     # protein => $bool # indicates a protein alignment
71 :     #
72 :     #-------------------------------------------------------------------------------
73 :     # Color an alignment by consensus
74 :     #
75 :     # \@align = color_alignment_by_consensus( \@align, \%options )
76 :     # \@align = color_alignment_by_consensus( \%options )
77 :     # ( \@align, \%legend ) = color_alignment_by_consensus( \@align, \%options )
78 :     # ( \@align, \%legend ) = color_alignment_by_consensus( \%options )
79 :     #
80 :     # Options:
81 :     #
82 :     # align => \@alignment # Alignment if not supplied as parameter
83 :     # alignment => \@alignment # Alignment if not supplied as parameter
84 :     # colors => \%colors # HTML colors for consensus categories
85 :     # matrix => \%scr_matrix # Hash of hashes of character align scores
86 :     # max_f_diff => $max_f_diff # Maximum fraction exceptions to consensus
87 :     # max_n_diff => $max_n_diff # Maximum number of exceptions to consensus
88 :     # min_score => $score # Score for conservative change (D=1)
89 :     # protein => $is_protein # Indicates a protein alignment
90 :     #
91 :     #-------------------------------------------------------------------------------
92 :     # Make an html table with an alignment:
93 :     #
94 :     # $html = alignment_2_html_table( \@alignment, \%options )
95 :     # $html = alignment_2_html_table( \%options )
96 :     # ( $html, $javascript ) = alignment_2_html_table( \@alignment, \%options )
97 :     # ( $html, $javascript ) = alignment_2_html_table( \%options )
98 :     #
99 :     # In scalar context, the routine returns a single block of html that includes
100 :     # the JavaScript followed by the table. In list context, they are returned
101 :     # separately.
102 :     #
103 :     # Options:
104 :     #
105 :     # align => \@alignment # Alignment, when not a parameter
106 :     # alignment => \@alignment # Alignment, when not a parameter
107 :     # key => \@legend # Append the supplied legend
108 :     # legend => \@legend # Append the supplied legend
109 :     # nojavascript => $boolean # Omit the JavaScript for pop-ups
110 :     # tooltip => $boolean # Add pop-up tooltip to sequences
111 :     # tooltip => \%id2tip # (specify the tip for each id)
112 :     #
113 :     # Each sequence can be a string, or an array of [ text, color ] pairs.
114 :     # @legend is an array of lines of strings and/or [ text, color ] pairs.
115 :     #
116 :     # Default tooltip is the id and description, but user can supply a
117 :     # hash with arrays of alternative mouseover parameters:
118 :     #
119 :     # mouseover( @{ $tooltip->{ $id } } )
120 :     # mouseover( $ttl, $text, $menu, $parent, $ttl_color, $text_color )
121 :     #-------------------------------------------------------------------------------
122 :     # Make an html page with an alignment:
123 :     #
124 :     # $html = alignment_2_html_page( \@alignment, \%options )
125 :     # $html = alignment_2_html_page( \%options )
126 :     #
127 :     # Options:
128 :     #
129 :     # align => \@alignment
130 :     # alignment => \@alignment
131 :     # key => \@legend
132 :     # legend => \@legend
133 :     # title => $page_title
134 :     #
135 :     # Each sequence can be a string, or an array of character-color pairs.
136 :     #-------------------------------------------------------------------------------
137 : golsen 1.4 #
138 :     # 2009/08/25 -- Fix problem with wrap in the alignment.
139 :     # Change all #abc to #aabbcc format due to a browser issue.
140 :     #
141 :     #-------------------------------------------------------------------------------
142 : golsen 1.2
143 : golsen 1.1 # Some global defaults:
144 :    
145 :     my $max_n_diff = 1; # Maximum number of exceptions to consensus
146 :     my $max_f_diff = 0.10; # Maximum fraction exceptions to consensus
147 :     my $minblos = 1; # Minimum score to be called a conservative change
148 :    
149 :     #-------------------------------------------------------------------------------
150 :     # Prepend and/or append unaligned sequence data to a trimmed alignment:
151 :     #
152 :     # \@align = add_alignment_context( \@align, \@seqs, \%options )
153 :     # ( \@align, $pre_len, $ali_len, $suf_len ) = add_alignment_context( \@align, \@seqs, \%options )
154 :     #
155 :     # Options:
156 :     #
157 :     # max_prefix => $limit # limit of residues to be added at beginning
158 :     # max_suffix => $limit # limit of residues to be added at end
159 :     # pad_char => $char # character to pad beginning and end (D = ' ')
160 :     #
161 :     #-------------------------------------------------------------------------------
162 :     sub add_alignment_context
163 :     {
164 :     my ( $align, $seqs, $options ) = @_;
165 :    
166 :     $align && ( ref( $align ) eq 'ARRAY' )
167 :     && ( @$align > 0 )
168 :     or print STDERR "add_alignment_context called without valid alignment\n"
169 :     and return undef;
170 :    
171 :     $seqs && ( ref( $seqs ) eq 'ARRAY' )
172 :     && ( @$seqs > 0 )
173 :     or print STDERR "add_alignment_context called without valid sequences\n"
174 :     and return undef;
175 :    
176 :     my %index = map { $_->[0], $_ } @$seqs;
177 :    
178 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
179 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
180 :    
181 :     my $max_prefix = defined( $options{ maxprefix } ) ? $options{ maxprefix } : 1e100;
182 :     my $max_suffix = defined( $options{ maxsuffix } ) ? $options{ maxsuffix } : 1e100;
183 :     my $pad_char = $options{ padchar } ? substr( $options{ padchar }, 0, 1 ) : ' ';
184 :    
185 :     my $pre_len = 0;
186 :     my $ali_len = length( $align->[0]->[2] );
187 :     my $suf_len = 0;
188 :    
189 :     my %fix_data = ();
190 :     my ( $id, $def, $aln_seq );
191 :     my ( $pre0, $npre, $suf0, $nsuf );
192 :     my ( $aligned, $full, $pos );
193 :    
194 :     foreach ( @$align )
195 :     {
196 :     ( $id, $def, $aln_seq ) = @$_;
197 :     if ( $index{$id} )
198 :     {
199 :     $aligned = lc $aln_seq;
200 :     $aligned =~ tr/a-z//cd;
201 :     $full = lc $index{$id}->[2];
202 :     $pos = index( $full, $aligned );
203 :     if ( $pos > -1 )
204 :     {
205 :     $npre = ( $pos <= $max_prefix ) ? $pos : $max_prefix;
206 :     $pre0 = $pos - $npre;
207 :     if ( $npre > $pre_len ) { $pre_len = $npre }
208 :     $suf0 = $pos + length( $aligned );
209 :     $nsuf = length( $full ) - $suf0;
210 :     $nsuf = $max_suffix if $nsuf > $max_suffix;
211 :     if ( $nsuf > $suf_len ) { $suf_len = $nsuf }
212 :     }
213 :     else
214 :     {
215 :     $npre = 0;
216 :     $nsuf = 0;
217 :     }
218 :     }
219 :     $fix_data{ $id } = [ $pre0, $npre, $suf0, $nsuf, $index{$id} ];
220 :     }
221 :    
222 :     my @align2;
223 :     my ( @parts, $seq_entry );
224 :     foreach ( @$align )
225 :     {
226 :     ( $id, $def, $aln_seq ) = @$_;
227 :     ( $pre0, $npre, $suf0, $nsuf, $seq_entry ) = @{ $fix_data{ $id } };
228 :    
229 :     @parts = ();
230 :     push @parts, $pad_char x ( $pre_len - $npre ) if ( $npre < $pre_len );
231 :     push @parts, lc substr( $seq_entry->[2], $pre0, $npre ) if $npre;
232 :     $aln_seq =~ s/^([^A-Za-z.]+)/$pad_char x length($1)/e if ( $pre_len && ! $npre );
233 :     $aln_seq =~ s/([^A-Za-z.]+)$/$pad_char x length($1)/e if ( $suf_len && ! $nsuf );
234 :     push @parts, uc $aln_seq;
235 :     push @parts, lc substr( $seq_entry->[2], $suf0, $nsuf ) if $nsuf;
236 :     push @parts, $pad_char x ( $suf_len - $nsuf ) if ( $nsuf < $suf_len );
237 :    
238 :     push @align2, [ $id, $def, join( '', @parts ) ];
239 :     }
240 :    
241 :     wantarray ? ( \@align2, $pre_len, $ali_len, $suf_len ) : \@align2;
242 :     }
243 :    
244 :    
245 :     #-------------------------------------------------------------------------------
246 :     # Change the pad character at the ends of an alignment:
247 :     #
248 :     # \@align = repad_alignment( \@align, \%options )
249 :     # \@align = repad_alignment( \%options )
250 :     # @align = repad_alignment( \@align, \%options )
251 :     # @align = repad_alignment( \%options )
252 :     #
253 :     # Options:
254 :     #
255 :     # pad_char => $char # character to pad beginning and end (D = ' ')
256 :     # old_pad => $regexp # characters to replace at end (D = [^A-Za-z.*])
257 :     #
258 :     #-------------------------------------------------------------------------------
259 :     sub repad_alignment
260 :     {
261 :     my $align;
262 :     $align = shift if ( ref($_[0]) eq 'ARRAY' );
263 :    
264 :     my %data = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
265 :     foreach ( keys %data ) { $data{ canonical_key( $_ ) } = $data{ $_ } }
266 :    
267 :     $align ||= $data{ align } || $data{ alignment };
268 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
269 :     {
270 :     print STDERR "repad_alignment called without alignment\n";
271 :     return ();
272 :     }
273 :    
274 :     $data{ padchar } ||= $data{ pad }; # Make this a fallback synonym;
275 :     my $pad_char = $data{ padchar } ? substr( $data{ padchar }, 0, 1 ) : ' ';
276 :    
277 :     $data{ oldpad } ||= $data{ old }; # Make this a fallback synonym;
278 :     my $old_pad = $data{ oldpad } ? $data{ padchar } : '[^A-Za-z.*]';
279 :     my $reg1 = qr/^($old_pad+)/;
280 :     my $reg2 = qr/($old_pad+)$/;
281 :    
282 :     my ( $id, $def, $seq );
283 :     my @align2 = ();
284 :    
285 :     foreach ( @$align )
286 :     {
287 :     ( $id, $def, $seq ) = @$_;
288 :     $seq =~ s/$reg1/$pad_char x length($1)/e;
289 :     $seq =~ s/$reg2/$pad_char x length($1)/e;
290 :     push @align2, [ $id, $def, $seq ];
291 :     }
292 :    
293 :     wantarray ? @align2 : \@align2;
294 :     }
295 :    
296 :    
297 :     #-------------------------------------------------------------------------------
298 :     # Color an alignment by residue type
299 :     #
300 :     # \@align = color_alignment_by_residue( \@align, \%options )
301 :     # \@align = color_alignment_by_residue( \%options )
302 :     # ( \@align, \@legend ) = color_alignment_by_residue( \@align, \%options )
303 :     # ( \@align, \@legend ) = color_alignment_by_residue( \%options )
304 :     #
305 :     # Options:
306 :     #
307 :     # align => \@alignment # alignment if not supplied as parameter
308 :     # alignment => \@alignment # alignment if not supplied as parameter
309 :     # colors => \%colors # character colors (html spec.)
310 :     # pallet => $pallet # ale | gde | default
311 :     # protein => $bool # indicates a protein alignment
312 :     #
313 :     #-------------------------------------------------------------------------------
314 :     sub color_alignment_by_residue
315 :     {
316 :     my $align;
317 :     $align = shift if ( ref($_[0]) eq 'ARRAY' );
318 :    
319 :     my %data = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
320 :     foreach ( keys %data ) { $data{ canonical_key( $_ ) } = $data{ $_ } }
321 :    
322 :     $align ||= $data{ align } || $data{ alignment };
323 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
324 :     {
325 :     print STDERR "color_alignment_by_residue called without alignment\n";
326 :     return ();
327 :     }
328 :    
329 :     my $colors = $data{ color };
330 :     if ( $colors && ( ref( $colors ) eq 'HASH' ) )
331 :     {
332 :     print STDERR "color_alignment_by_residue called without invalid colors hash\n";
333 :     return ();
334 :     }
335 :    
336 :     if ( ! $colors )
337 :     {
338 :     my $is_prot = defined( $data{ protein } ) ? $data{ protein } : &guess_prot( $align );
339 :     my $pallet = $data{ pallet };
340 :     $colors = $is_prot ? aa_colors( $pallet ) : nt_colors( $pallet );
341 :     }
342 :    
343 :     my ( $id, $def, $seq );
344 :     my $pad_char = $data{ padchar } || $data{ pad } || ' ';
345 :     my $reg1 = qr/^([^A-Za-z.*]+)/;
346 :     my $reg2 = qr/([^A-Za-z.*]+)$/;
347 :     my @colored_align = ();
348 :    
349 :     foreach ( @$align )
350 :     {
351 :     ( $id, $def, $seq ) = @$_;
352 :     $seq =~ s/$reg1/$pad_char x length($1)/e;
353 :     $seq =~ s/$reg2/$pad_char x length($1)/e;
354 :     push @colored_align, [ $id, $def, scalar color_sequence( $seq, $colors ) ];
355 :     }
356 :    
357 :     my @legend = (); # Need to create this still
358 :     if ( wantarray )
359 :     {
360 :     my ( $i, $chr );
361 :     my @row = ();
362 :     foreach ( $i = 32; $i < 127; $i++ )
363 :     {
364 :     $chr = chr( $i );
365 : golsen 1.4 push @row, [ $chr, $colors->{$chr} || '#ffffff' ];
366 : golsen 1.1 if ( $i % 32 == 31 ) { push @legend, [ @row ]; @row = () }
367 :     }
368 :     push @legend, [ @row ];
369 :     }
370 :    
371 :     wantarray ? ( \@colored_align, \@legend ) : \@colored_align;
372 :     }
373 :    
374 :    
375 :     #-------------------------------------------------------------------------------
376 :     # Convert sequence to list of character-color pairs:
377 :     #
378 :     # \@colored_sequence = color_sequence( $sequence, \%colors )
379 :     # @colored_sequence = color_sequence( $sequence, \%colors )
380 :     #-------------------------------------------------------------------------------
381 :     sub color_sequence
382 :     {
383 :     my ( $seq, $colors ) = @_;
384 :     my %colors = ref($colors) eq 'HASH' ? %$colors : ();
385 : golsen 1.4 my @colored_seq = map { [ $_, $colors{ $_ } || '#ffffff' ] } split //, $seq;
386 : golsen 1.1 wantarray ? @colored_seq : \@colored_seq;
387 :     }
388 :    
389 :    
390 :     #-------------------------------------------------------------------------------
391 :     # Color an alignment by consensus
392 :     #
393 :     # \@align = color_alignment_by_consensus( \@align, \%options )
394 :     # \@align = color_alignment_by_consensus( \%options )
395 :     # ( \@align, \%legend ) = color_alignment_by_consensus( \@align, \%options )
396 :     # ( \@align, \%legend ) = color_alignment_by_consensus( \%options )
397 :     #
398 :     # Options:
399 :     #
400 :     # align => \@alignment # Alignment if not supplied as parameter
401 :     # alignment => \@alignment # Alignment if not supplied as parameter
402 :     # colors => \%colors # HTML colors for consensus categories
403 :     # matrix => \%scr_matrix # Hash of hashes of character align scores
404 :     # max_f_diff => $max_f_diff # Maximum fraction exceptions to consensus
405 :     # max_n_diff => $max_n_diff # Maximum number of exceptions to consensus
406 :     # min_score => $score # Score for conservative change (D=1)
407 :     # protein => $is_protein # Indicates a protein alignment
408 :     #
409 :     #-------------------------------------------------------------------------------
410 :     sub color_alignment_by_consensus
411 :     {
412 :     my $align;
413 :     $align = shift if ( ref($_[0]) eq 'ARRAY' );
414 :    
415 :     # Options, with canonical form of keys
416 :    
417 :     my %data = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
418 :     foreach ( keys %data ) { $data{ canonical_key( $_ ) } = $data{ $_ } }
419 :    
420 :     $align ||= $data{ align } || $data{ alignment };
421 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
422 :     {
423 :     print STDERR "color_alignment_by_consensus called without alignment\n";
424 :     return ();
425 :     }
426 :    
427 :     my ( $pallet, $legend ) = consensus_pallet( $data{ color } );
428 :    
429 :     my $conserve_list = conservative_change_list( \%data );
430 :     my $conserve_hash = conservative_change_hash( \%data );
431 :    
432 :     my $chars = qr/^[-*A-Za-z]$/;
433 :    
434 :     my $s;
435 :     my $pad_char = $data{ padchar } || $data{ pad } || ' ';
436 :     my $reg1 = qr/^([^A-Za-z.*]+)/;
437 :     my $reg2 = qr/([^A-Za-z.*]+)$/;
438 :    
439 :     my @seq = map { $s = uc $_->[2];
440 :     $s =~ s/$reg1/$pad_char x length($1)/e;
441 :     $s =~ s/$reg2/$pad_char x length($1)/e;
442 :     $s
443 :     }
444 :     @$align;
445 :    
446 :     # Define the consensus type(s) for each site. There are a 3 options:
447 :     # 1. There is a single consensus nucleotide.
448 :     # 2. Two residue types are sufficient to describe the position.
449 :     # 3. A residue and conservative changes are sufficient.
450 :    
451 :     my $len = length( $seq[0] );
452 :    
453 :     $max_n_diff = $data{ maxndiff } if defined( $data{ maxndiff } );
454 :     $max_f_diff = $data{ maxfdiff } if defined( $data{ maxfdiff } );
455 :    
456 :     my @col_clr; # An array of hashes, one for each column
457 :     my $cons1 = ' ' x $len; # Primary consensus characters
458 :     my $cons2 = ' ' x $len; # Secondary consensus characters
459 :    
460 :     my ( $i, %cnt, $chr, @c, $n_signif, $min_consen, $c1, $c2, $clr );
461 :    
462 :     for ( $i = 0; $i < $len; $i++)
463 :     {
464 :     # Count the number of each residue type in the column
465 :    
466 :     %cnt = ();
467 :     foreach ( @seq ) { $chr = substr($_,$i,1); $cnt{$chr}++ if $chr =~ /$chars/ }
468 :    
469 :     $n_signif = sum( map { $cnt{$_} } keys %cnt );
470 :     $min_consen = $n_signif - max( $max_n_diff, int( $max_f_diff * $n_signif ) );
471 :    
472 :     ( $c1, $c2, @c ) = consensus_residues( \%cnt, $min_consen, $conserve_hash );
473 :    
474 :     substr( $cons1, $i, 1 ) = $c1 if $c1;
475 :     substr( $cons2, $i, 1 ) = $c2 if $c2;
476 :     push @col_clr, consensus_colors( $pallet, $conserve_list, $c1, $c2, @c );
477 :     }
478 :    
479 :     my @color_align = ();
480 : golsen 1.3 my ( $id, $def, $seq );
481 : golsen 1.1 foreach ( @$align, [ 'Consen1', 'Primary consensus', $cons1 ],
482 :     [ 'Consen2', 'Secondary consensus', $cons2 ]
483 :     )
484 :     {
485 :     ( $id, $def, $seq ) = @$_;
486 :     $seq =~ s/^([^A-Za-z.]+)/$pad_char x length($1)/e;
487 :     $seq =~ s/([^A-Za-z.]+)$/$pad_char x length($1)/e;
488 :    
489 :     $i = 0;
490 : golsen 1.4 my @clr_seq = map { [ $_, $col_clr[$i++]->{$_} || '#ffffff' ] }
491 : golsen 1.1 split //, $seq;
492 :     push @color_align, [ $id, $def, \@clr_seq ];
493 :     }
494 :    
495 :     wantarray ? ( \@color_align, $legend ) : \@color_align;
496 :     }
497 :    
498 :    
499 :     #-------------------------------------------------------------------------------
500 :     # Work out the consensus residues at a site:
501 :     #
502 :     # ( $consen1, $consen2, @chars ) = consensus_residues( $counts, $min_match,
503 :     # $conserve_hash )
504 :     #-------------------------------------------------------------------------------
505 :     sub consensus_residues
506 :     {
507 :     my ( $cnt_hash, $min_match, $conserve_hash ) = @_;
508 :    
509 :     # Sort the residues from most to least frequent, and note first 2:
510 :    
511 :     my %cnt = %$cnt_hash;
512 :     my ( $c1, $c2, @c );
513 :    
514 :     ( $c1, $c2 ) = @c = sort { $cnt{$b} <=> $cnt{$a} } keys %cnt;
515 :     ( $cnt{$c1} >= 2 ) or return ( '', '' );
516 :    
517 :     # Are there at least $min_match of the most abundant?
518 :    
519 :     if ( $cnt{$c1} >= $min_match )
520 :     {
521 :     $c2 = '';
522 :     }
523 :    
524 :     # Are there at least $min_match of the two most abundant?
525 :    
526 :     elsif ( ( $cnt{$c2} >= 2 ) && ( ( $cnt{$c1} + $cnt{$c2} ) >= $min_match ) )
527 :     {
528 :     $c1 = lc $c1;
529 :     $c2 = lc $c2;
530 :     }
531 :    
532 :     # Can we make a consensus of conservative changes?
533 :    
534 :     else
535 :     {
536 :     $c2 = '';
537 :     my ( $is_conservative, @pos, $total );
538 :     my $found = 0;
539 :     foreach $c1 ( grep { /^[AC-IK-NP-TVWY]$/ } @c )
540 :     {
541 :     ( $is_conservative = $conserve_hash->{ $c1 } ) or next;
542 :     @pos = grep { $is_conservative->{ $_ } } @c;
543 :     $total = sum( map { $cnt{ $_ } } @pos );
544 :     if ( $total >= $min_match ) { $found = 1; last }
545 :     }
546 :     $c1 = $found ? lc $c1 : '';
547 :     }
548 :    
549 :     return ( $c1, $c2, @c );
550 :     }
551 :    
552 :    
553 :     #-------------------------------------------------------------------------------
554 :     # Work out the residue colors for the consensus at a site:
555 :     #
556 :     # \%color = consensus_colors( $pallet, $consevative, $cons1, $cons2, @chars )
557 :     #-------------------------------------------------------------------------------
558 :     sub consensus_colors
559 :     {
560 :     my ( $pallet, $conservative, $c1, $c2, @c ) = @_;
561 :     # print STDERR Dumper( $c1, $c2, \@c ); exit;
562 :     return {} if ! $c1;
563 :    
564 :     my %pallet = ( ref($pallet) eq 'HASH' ) ? %$pallet
565 :     : @{ scalar consensus_pallet() };
566 :    
567 :     $conservative = {} if ref( $conservative ) ne 'HASH';
568 :    
569 :     # Mark everything but ' ' and . as mismatch, then overwrite exceptions:
570 :    
571 :     my %color = map { $_ => $pallet{ mismatch } }
572 :     grep { ! /^[ .]$/ }
573 :     @c;
574 :    
575 :     if ( $c1 ne '-' )
576 :     {
577 :     $c1 = uc $c1;
578 :     foreach ( @{ $conservative->{$c1} || [] } )
579 :     {
580 :     $color{ $_ } = $pallet{ positive }
581 :     }
582 :     $color{ $c1 } = $pallet{ consen1 };
583 :     if ( $c2 )
584 :     {
585 :     $color{ uc $c2 } = ( $c2 ne '-' ) ? $pallet{ consen2 } : $pallet{ consen2g };
586 :     }
587 :     }
588 :     else
589 :     {
590 :     $color{ $c1 } = $pallet{ consen1g };
591 :     if ( $c2 ) { $color{ uc $c2 } = $pallet{ consen2 } }
592 :     }
593 :    
594 :     # Copy colors to lowercase letters:
595 :    
596 :     foreach ( grep { /^[A-Z]$/ } keys %color )
597 :     {
598 :     $color{ lc $_ } = $color{ $_ }
599 :     }
600 :    
601 :     return \%color;
602 :     }
603 :    
604 :    
605 :     #-------------------------------------------------------------------------------
606 :     # Numerical maximum:
607 :     #
608 :     # $max = max( $a, $b )
609 :     #-------------------------------------------------------------------------------
610 :     sub max { $_[0] > $_[1] ? $_[0] : $_[1] }
611 :    
612 :    
613 :     #-------------------------------------------------------------------------------
614 :     # Define the colors used to color by consensus:
615 :     #
616 :     # \%color_pallet = consensus_pallet()
617 :     # \%color_pallet = consensus_pallet( \%user_pallet )
618 :     # ( \%color_pallet, \@legend ) = consensus_pallet()
619 :     # ( \%color_pallet, \@legend ) = consensus_pallet( \%user_pallet )
620 :     #
621 :     # \%color_pallet is key/color pairs, where key is a residue category
622 :     # \@legend is lines of text/color pairs
623 :     #-------------------------------------------------------------------------------
624 :     sub consensus_pallet
625 :     {
626 :     # Initialize with a standard set, ensuring that all keys are covered:
627 :    
628 : golsen 1.4 my %pallet = ( '' => '#ffffff',
629 :     other => '#ffffff',
630 :     consen1 => '#bbddff', consen1g => '#ddeeff',
631 :     positive => '#66ee99',
632 :     consen2 => '#eeee44', consen2g => '#eeeeaa',
633 :     mismatch => '#ff99ff'
634 : golsen 1.1 );
635 :    
636 :     # Overwrite defaults with user-supplied colors
637 :    
638 :     if ( ref($_[0]) eq 'HASH' )
639 :     {
640 :     my %user_pallet = %{ $_[0] };
641 :     foreach ( keys %user_pallet ) { $pallet{ $_ } = $user_pallet{ $_ } }
642 :     }
643 :    
644 :     my @legend;
645 :     if ( wantarray )
646 :     {
647 :     @legend = ( [ [ 'Consensus 1' => $pallet{ consen1 } ],
648 :     [ ' (when a gap)' => $pallet{ consen1g } ] ],
649 :    
650 :     [ [ 'Conservative difference' => $pallet{ positive } ] ],
651 :    
652 :     [ [ 'Consensus 2' => $pallet{ consen2 } ],
653 :     [ ' (when a gap)' => $pallet{ consen2g } ] ],
654 :    
655 :     [ [ 'Nonconservative diff.' => $pallet{ mismatch } ] ],
656 :    
657 :     [ [ 'Other character' => $pallet{ '' } ] ],
658 :     );
659 :     }
660 :    
661 :     wantarray ? ( \%pallet, \@legend ) : \%pallet;
662 :     }
663 :    
664 :    
665 :     #-------------------------------------------------------------------------------
666 :     # Define the list of conserved amino acid replacements for each amino acid:
667 :     #
668 :     # \%conserve_change_lists = conservative_change_list( \%options )
669 :     # \%conserve_change_lists = conservative_change_list( %options )
670 :     #
671 :     # \@conserve_changes = $conserve_change_lists->{ $aa };
672 :     #
673 :     # Options:
674 :     #
675 :     # min_score => $score # Minimum score for conservative designation
676 :     # matrix => \%score_hash # Score matrix as hash of hashes
677 :     #-------------------------------------------------------------------------------
678 :     sub conservative_change_list
679 :     {
680 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
681 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
682 :    
683 :     my $min_score = defined( $options{ minscore } ) ? $options{ minscore } : 1;
684 :    
685 :     my $matrix = ( ref( $options{ matrix } ) eq 'HASH' ) ? $options{ matrix }
686 :     : blosum62_hash_hash();
687 :    
688 :     my %hash;
689 :     foreach ( keys %$matrix )
690 :     {
691 :     my $score = $matrix->{ $_ };
692 :     $hash{ $_ } = [ grep { $score->{ $_ } >= $min_score } keys %$score ];
693 :     }
694 :     return \%hash;
695 :     }
696 :    
697 :    
698 :     #-------------------------------------------------------------------------------
699 :     # Define a hash of conserved amino acid replacements for each amino acid:
700 :     #
701 :     # \%conserve_change_hashes = conservative_change_hash( \%options )
702 :     # \%conserve_change_hashes = conservative_change_hash( %options )
703 :     #
704 :     # \%conserve_changes = $conserve_change_hashes->{ $aa };
705 :     #
706 :     # Options:
707 :     #
708 :     # min_score => $score # Minimum score for conservative designation
709 :     # matrix => \%score_hash # Score matrix as hash of hashes
710 :     #-------------------------------------------------------------------------------
711 :     sub conservative_change_hash
712 :     {
713 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
714 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
715 :    
716 :     my $min_score = defined( $options{ minscore } ) ? $options{ minscore } : 1;
717 :    
718 :     my $matrix = ( ref( $options{ matrix } ) eq 'HASH' ) ? $options{ matrix }
719 :     : blosum62_hash_hash();
720 :    
721 :     my %hash;
722 :     foreach ( keys %$matrix )
723 :     {
724 :     my $score = $matrix->{ $_ };
725 :     $hash{ $_ } = { map { $_ => 1 }
726 :     grep { $score->{ $_ } >= $min_score }
727 :     keys %$score
728 :     };
729 :     }
730 :    
731 :     return \%hash;
732 :     }
733 :    
734 :    
735 :     #-------------------------------------------------------------------------------
736 :     # Define a hash of hashes with the blosum62 scores for each amino acid:
737 :     #
738 :     # \%blosum62 = blosum62_hash_hash()
739 :     # $score = $blosum62->{$aa1}->{$aa2};
740 :     #
741 :     #-------------------------------------------------------------------------------
742 :     sub blosum62_hash_hash
743 :     {
744 :     my ( $aa_list, $raw_scores ) = raw_blosum62();
745 :     my %hash;
746 :     my @scores = @$raw_scores;
747 :     foreach ( @$aa_list )
748 :     {
749 :     my @scr = @{ shift @scores };
750 :     $hash{ $_ } = { map { $_ => shift @scr } @$aa_list };
751 :     }
752 :     return \%hash;
753 :     }
754 :    
755 :    
756 :     #-------------------------------------------------------------------------------
757 :     # Define an ordered list of aminoacids and lists of each of their blosum scores
758 :     #
759 :     # ( \@aa_list, \@scores ) = raw_blosum62()
760 :     #
761 :     #-------------------------------------------------------------------------------
762 :     sub raw_blosum62
763 :     {
764 :     return ( [ qw( A R N D C Q E G H I L K M F P S T W Y V B Z X * ) ],
765 :     [ map { shift @$_; $_ }
766 :     (
767 :     # A R N D C Q E G H I L K M F P S T W Y V B Z X * #
768 :     [ qw( A 4 -1 -2 -2 0 -1 -1 0 -2 -1 -1 -1 -1 -2 -1 1 0 -3 -2 0 -2 -1 0 -4 ) ],
769 :     [ qw( R -1 5 0 -2 -3 1 0 -2 0 -3 -2 2 -1 -3 -2 -1 -1 -3 -2 -3 -1 0 -1 -4 ) ],
770 :     [ qw( N -2 0 6 1 -3 0 0 0 1 -3 -3 0 -2 -3 -2 1 0 -4 -2 -3 3 0 -1 -4 ) ],
771 :     [ qw( D -2 -2 1 6 -3 0 2 -1 -1 -3 -4 -1 -3 -3 -1 0 -1 -4 -3 -3 4 1 -1 -4 ) ],
772 :     [ qw( C 0 -3 -3 -3 9 -3 -4 -3 -3 -1 -1 -3 -1 -2 -3 -1 -1 -2 -2 -1 -3 -3 -2 -4 ) ],
773 :     [ qw( Q -1 1 0 0 -3 5 2 -2 0 -3 -2 1 0 -3 -1 0 -1 -2 -1 -2 0 3 -1 -4 ) ],
774 :     [ qw( E -1 0 0 2 -4 2 5 -2 0 -3 -3 1 -2 -3 -1 0 -1 -3 -2 -2 1 4 -1 -4 ) ],
775 :     [ qw( G 0 -2 0 -1 -3 -2 -2 6 -2 -4 -4 -2 -3 -3 -2 0 -2 -2 -3 -3 -1 -2 -1 -4 ) ],
776 :     [ qw( H -2 0 1 -1 -3 0 0 -2 8 -3 -3 -1 -2 -1 -2 -1 -2 -2 2 -3 0 0 -1 -4 ) ],
777 :     [ qw( I -1 -3 -3 -3 -1 -3 -3 -4 -3 4 2 -3 1 0 -3 -2 -1 -3 -1 3 -3 -3 -1 -4 ) ],
778 :     [ qw( L -1 -2 -3 -4 -1 -2 -3 -4 -3 2 4 -2 2 0 -3 -2 -1 -2 -1 1 -4 -3 -1 -4 ) ],
779 :     [ qw( K -1 2 0 -1 -3 1 1 -2 -1 -3 -2 5 -1 -3 -1 0 -1 -3 -2 -2 0 1 -1 -4 ) ],
780 :     [ qw( M -1 -1 -2 -3 -1 0 -2 -3 -2 1 2 -1 5 0 -2 -1 -1 -1 -1 1 -3 -1 -1 -4 ) ],
781 :     [ qw( F -2 -3 -3 -3 -2 -3 -3 -3 -1 0 0 -3 0 6 -4 -2 -2 1 3 -1 -3 -3 -1 -4 ) ],
782 :     [ qw( P -1 -2 -2 -1 -3 -1 -1 -2 -2 -3 -3 -1 -2 -4 7 -1 -1 -4 -3 -2 -2 -1 -2 -4 ) ],
783 :     [ qw( S 1 -1 1 0 -1 0 0 0 -1 -2 -2 0 -1 -2 -1 4 1 -3 -2 -2 0 0 0 -4 ) ],
784 :     [ qw( T 0 -1 0 -1 -1 -1 -1 -2 -2 -1 -1 -1 -1 -2 -1 1 5 -2 -2 0 -1 -1 0 -4 ) ],
785 :     [ qw( W -3 -3 -4 -4 -2 -2 -3 -2 -2 -3 -2 -3 -1 1 -4 -3 -2 11 2 -3 -4 -3 -2 -4 ) ],
786 :     [ qw( Y -2 -2 -2 -3 -2 -1 -2 -3 2 -1 -1 -2 -1 3 -3 -2 -2 2 7 -1 -3 -2 -1 -4 ) ],
787 :     [ qw( V 0 -3 -3 -3 -1 -2 -2 -3 -3 3 1 -2 1 -1 -2 -2 0 -3 -1 4 -3 -2 -1 -4 ) ],
788 :     [ qw( B -2 -1 3 4 -3 0 1 -1 0 -3 -4 0 -3 -3 -2 0 -1 -4 -3 -3 4 1 -1 -4 ) ],
789 :     [ qw( Z -1 0 0 1 -3 3 4 -2 0 -3 -3 1 -1 -3 -1 0 -1 -3 -2 -2 1 4 -1 -4 ) ],
790 :     [ qw( X 0 -1 -1 -1 -2 -1 -1 -1 -1 -1 -1 -1 -1 -1 -2 0 0 -2 -1 -1 -1 -1 -1 -4 ) ],
791 :     [ qw( * -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 1 ) ]
792 :     )
793 :     ]
794 :     )
795 :     }
796 :    
797 :    
798 :     #-------------------------------------------------------------------------------
799 :     # Make an html table with an alignment:
800 :     #
801 :     # $html = alignment_2_html_table( \@alignment, \%options )
802 :     # $html = alignment_2_html_table( \%options )
803 :     # ( $html, $javascript ) = alignment_2_html_table( \@alignment, \%options )
804 :     # ( $html, $javascript ) = alignment_2_html_table( \%options )
805 :     #
806 :     # In scalar context, the routine returns a single block of html that includes
807 :     # the JavaScript followed by the table. In list context, they are returned
808 :     # separately.
809 :     #
810 :     # Options:
811 :     #
812 :     # align => \@alignment # Alignment, when not a parameter
813 :     # alignment => \@alignment # Alignment, when not a parameter
814 :     # key => \@legend # Append the supplied legend
815 :     # legend => \@legend # Append the supplied legend
816 :     # nojavascript => $boolean # Omit the JavaScript for pop-ups
817 :     # tooltip => $boolean # Add pop-up tooltip to sequences
818 : golsen 1.2 # tooltip => \%id2tip # (specify the tip for each id)
819 : golsen 1.1 #
820 :     # Each sequence can be a string, or an array of [ text, color ] pairs.
821 :     # @legend is an array of lines of strings and/or [ text, color ] pairs.
822 : golsen 1.2 #
823 :     # Default tooltip is the id and description, but user can supply a
824 :     # hash with arrays of alternative mouseover parameters:
825 :     #
826 :     # mouseover( @{ $tooltip->{ $id } } )
827 :     # mouseover( $ttl, $text, $menu, $parent, $ttl_color, $text_color )
828 : golsen 1.1 #-------------------------------------------------------------------------------
829 :     sub alignment_2_html_table
830 :     {
831 :     my $align;
832 :     $align = shift if ( ref($_[0]) eq 'ARRAY' );
833 :    
834 :     # Options, with canonical form of keys
835 :    
836 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
837 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
838 :    
839 :     $align ||= $options{ align } || $options{ alignment };
840 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
841 :     {
842 :     print STDERR "alignment_2_html_table called without alignment\n";
843 :     return '';
844 :     }
845 :    
846 :     my $tooltip = $options{ tooltip } || $options{ popup } || 0;
847 :     my $tiplink = '';
848 :    
849 :     my $nojavascript = $options{ nojavascript } || ( $tooltip ? 0 : 1 );
850 :    
851 :     my @html;
852 : golsen 1.3 push @html, "<TABLE Col=5 CellPadding=0 CellSpacing=0>\n";
853 : golsen 1.1 foreach ( @$align )
854 :     {
855 :     if ( $tooltip )
856 :     {
857 : golsen 1.2 # Default tooltip is the id and description, but user can supply a
858 :     # hash with alternative mouseover parameters:
859 :     #
860 :     # mouseover( $ttl, $text, $menu, $parent, $ttl_color, $text_color )
861 :     #
862 :     my @args;
863 :     if ( ( ref( $tooltip ) eq 'HASH' )
864 :     && ( ref( $tooltip->{ $_->[0] } ) eq 'ARRAY' )
865 :     )
866 :     {
867 :     @args = @{ $tooltip->{ $_->[0] } }
868 :     }
869 :     else
870 :     {
871 :     @args = ( $_->[0], ( $_->[1] || ' ' ) );
872 :     }
873 : golsen 1.1 $tiplink = '<A' . &mouseover( @args ) . '>';
874 :     }
875 :    
876 :     push @html, " <TR>\n",
877 :     " <TD NoWrap>$_->[0]</TD>\n",
878 : golsen 1.3 " <TD NoWrap>&nbsp;</TD>\n", # Getting rid of padding, so ...
879 : golsen 1.1 " <TD NoWrap>$_->[1]</TD>\n",
880 : golsen 1.3 " <TD NoWrap>&nbsp;</TD>\n", # Getting rid of padding, so ...
881 :     " <TD NoWrap>&nbsp;</TD>\n",
882 : golsen 1.4 " <TD NoWrap><TT><Big>", # Switch from <PRE> to <TT> requires nowrap -- 2009/08/25
883 : golsen 1.1 ( $tooltip ? $tiplink : () ),
884 :     sequence_2_html( $_->[2] ),
885 :     ( $tooltip ? '</A>' : () ),
886 : golsen 1.3 "</Big></TT></TD>\n",
887 : golsen 1.1 " </TR>\n";
888 :     }
889 :     push @html, "</TABLE>\n";
890 :    
891 :     my $legend = $options{ key } || $options{ legend };
892 :     if ( ref( $legend ) eq 'ARRAY' )
893 :     {
894 : golsen 1.3 push @html, "<BR />\n", "<TABLE Col=1 CellPadding=0 CellSpacing=0>\n";
895 : golsen 1.1 foreach ( @$legend )
896 :     {
897 : golsen 1.3 push @html, " <TR><TD><TT><Big>",
898 : golsen 1.1 sequence_2_html( $_ ),
899 : golsen 1.3 "</Big></TT></TD></TR>\n";
900 : golsen 1.1 }
901 :     push @html, "</TABLE>\n";
902 :     }
903 :    
904 :     my $javascript = $nojavascript ? '' : &mouseover_JavaScript();
905 :    
906 :     wantarray && $javascript ? ( join( '', @html ), $javascript ) # ( $html, $script )
907 :     : join( '', $javascript, @html ); # $html
908 :     }
909 :    
910 :    
911 :     #-------------------------------------------------------------------------------
912 :     # Make html to display a possibly colored sequence:
913 :     #
914 :     # $html = sequence_2_html( $string )
915 :     # $html = sequence_2_html( \@character_color_pairs )
916 :     #
917 :     # Each sequence can be a string, or an array of character-color pairs.
918 :     #-------------------------------------------------------------------------------
919 :     sub sequence_2_html
920 :     {
921 :     return $_[0] if ref( $_[0] ) ne 'ARRAY';
922 :    
923 :     my $string = shift;
924 :     my @html = ();
925 :     my ( $txt, $clr );
926 :     foreach ( @{ merge_common_color( $string ) } )
927 :     {
928 :     $txt = html_esc( $_->[0] );
929 :     $txt or next;
930 : golsen 1.3 $txt =~ s/ /&nbsp;/g; # 2009-03-02 -- Change from <Pre> to <TT> wrapper
931 : golsen 1.1 $clr = $_->[1];
932 :     push @html, ( $clr ? qq(<span style="background-color:$clr">$txt</span>)
933 :     : $txt
934 :     )
935 :     }
936 :     join '', @html;
937 :     }
938 :    
939 :    
940 :     #-------------------------------------------------------------------------------
941 :     # Merge adjacent strings with same color to cut amount of html:
942 :     #
943 :     # \@character_color_pairs = merge_common_color( \@character_color_pairs )
944 :     #
945 :     #-------------------------------------------------------------------------------
946 :     sub merge_common_color
947 :     {
948 :     return $_[0] if ref( $_[0] ) ne 'ARRAY';
949 :    
950 :     my @string = ();
951 :     my $color = '';
952 :     my @common_color = ();
953 :     foreach ( @{ $_[0] }, [ '', 0 ] ) # One bogus empty string to flush it
954 :     {
955 :     if ( $_->[1] ne $color )
956 :     {
957 :     push @string, [ join( '', @common_color ), $color ],
958 :     @common_color = ();
959 :     $color = $_->[1]
960 :     }
961 :     push @common_color, $_->[0];
962 :     }
963 :     return \@string;
964 :     }
965 :    
966 :    
967 :     #-------------------------------------------------------------------------------
968 :     # Make an html page with an alignment:
969 :     #
970 :     # $html = alignment_2_html_page( \@alignment, \%options )
971 :     # $html = alignment_2_html_page( \%options )
972 :     #
973 :     # Options:
974 :     #
975 :     # align => \@alignment
976 :     # alignment => \@alignment
977 :     # key => \@legend
978 :     # legend => \@legend
979 :     # title => $page_title
980 :     #
981 :     # Each sequence can be a string, or an array of character-color pairs.
982 :     #-------------------------------------------------------------------------------
983 :     sub alignment_2_html_page
984 :     {
985 :     my $options = ref( $_[0] ) eq 'HASH' ? $_[0] :
986 :     ref( $_[1] ) eq 'HASH' ? $_[1] : {};
987 :    
988 :     join '', html_prefix( $options ),
989 :     ( alignment_2_html_table( @_ ) )[1,0],
990 :     html_suffix( $options );
991 :     }
992 :    
993 :    
994 :     #-------------------------------------------------------------------------------
995 :     # $html_page_start = html_prefix()
996 :     #-------------------------------------------------------------------------------
997 :     sub html_prefix
998 :     {
999 :     my $options = ref( $_[0] ) eq 'HASH' ? $_[0] : {};
1000 :    
1001 :     my $title = $options->{ title } || 'Alignment';
1002 :    
1003 :     return <<"End_of_Prefix";
1004 :     <HTML>
1005 :     <HEAD>
1006 :     <TITLE>$title</TITLE>
1007 :     </HEAD>
1008 :     <BODY>
1009 :     End_of_Prefix
1010 :     }
1011 :    
1012 :    
1013 :     #-------------------------------------------------------------------------------
1014 :     # $html_page_end = html_suffix()
1015 :     #-------------------------------------------------------------------------------
1016 :     sub html_suffix
1017 :     {
1018 :     return <<"End_of_Suffix";
1019 :     </BODY>
1020 :     </HTML>
1021 :     End_of_Suffix
1022 :     }
1023 :    
1024 :    
1025 :     #-------------------------------------------------------------------------------
1026 :     # $html_text = html_esc{ $text )
1027 :     #-------------------------------------------------------------------------------
1028 :     sub html_esc
1029 :     {
1030 :     my $txt = shift;
1031 :     $txt =~ s/\&/&amp;/g;
1032 :     $txt =~ s/\</&lt;/g;
1033 :     $txt =~ s/\>/&gt;/g;
1034 :     return $txt;
1035 :     }
1036 :    
1037 :    
1038 :     sub sum
1039 :     {
1040 :     my $cnt = 0;
1041 :     while ( defined( $_[0] ) ) { $cnt += shift }
1042 :     $cnt
1043 :     }
1044 :    
1045 :    
1046 :     #-------------------------------------------------------------------------------
1047 :     # A canonical key is lower case, has no underscores, and no terminal s
1048 :     #
1049 :     # $key = canonical_key( $key )
1050 :     #-------------------------------------------------------------------------------
1051 :     sub canonical_key { my $key = lc shift; $key =~ s/_//g; $key =~ s/s$//; $key }
1052 :    
1053 :    
1054 :     #-------------------------------------------------------------------------------
1055 :     # $is_protein_alignment = guess_prot( \@alignment )
1056 :     #-------------------------------------------------------------------------------
1057 :     sub guess_prot
1058 :     {
1059 :     my $align = shift;
1060 :     my $seq = uc $align->[0]->[-1]; # First sequence
1061 :     my $nt = $seq =~ tr/ACGTU//; # Nucleotides
1062 :     my $res = $seq =~ tr/ACDEFGHIKLMNPQRSTUVWY//; # Total residues
1063 :     return ( $nt > 0.7 * $res ) ? 0 : 1; # >70% of total?
1064 :     }
1065 :    
1066 :    
1067 :    
1068 :     #-------------------------------------------------------------------------------
1069 :     # \%character_color_pallet = aa_colors() # Default
1070 :     # \%character_color_pallet = aa_colors( $set_name ) # ale
1071 :     #-------------------------------------------------------------------------------
1072 :     sub aa_colors
1073 :     {
1074 :     my $pallet = shift || '';
1075 :     my %colors;
1076 :    
1077 :     if ( $pallet =~ /ale/i )
1078 :     {
1079 :     %colors = (
1080 :     ' ' => '#bebebe', # Grey
1081 :     '~' => '#bebebe', # Grey
1082 :     '-' => '#696969', # DimGray
1083 :     '.' => '#828282', # Grey51
1084 :     '*' => '#ff0000', # Red
1085 :    
1086 :     G => '#ffffff', # White
1087 :    
1088 :     A => '#d3d3d3', # LightGray
1089 :     V => '#d3d3d3', # LightGray
1090 :     L => '#d3d3d3', # LightGray
1091 :     I => '#d3d3d3', # LightGray
1092 :     M => '#d3d3d3', # LightGray
1093 :     C => '#d3d3d3', # LightGray
1094 :     U => '#d3d3d3', # LightGray
1095 :    
1096 :     W => '#ffd700', # Gold
1097 :     F => '#ffd700', # Gold
1098 :     Y => '#ffd700', # Gold
1099 :    
1100 :     K => '#00bfff', # DeepSkyBlue
1101 :     R => '#00bfff', # DeepSkyBlue
1102 :     H => '#40e0d0', # Turquoise
1103 :    
1104 :     N => '#98fb98', # PaleGreen
1105 :     Q => '#98fb98', # PaleGreen
1106 :     S => '#98fb98', # PaleGreen
1107 :     T => '#98fb98', # PaleGreen
1108 :     P => '#98fb98', # PaleGreen
1109 :    
1110 :     D => '#fa8072', # Salmon
1111 :     E => '#fa8072', # Salmon
1112 :     );
1113 :     }
1114 :     else
1115 :     {
1116 :     %colors = (
1117 : golsen 1.4 ' ' => '#ffffff', # White
1118 :     '~' => '#ffffff', # White
1119 :     '.' => '#ffffff', # White
1120 :     '-' => '#888888', # Gray
1121 :     '*' => '#ff0000', # Red
1122 :    
1123 :     G => '#dd88dd', # DullMagenta
1124 :    
1125 :     A => '#dddddd', # LightGray
1126 :     V => '#dddddd', # LightGray
1127 :     L => '#dddddd', # LightGray
1128 :     I => '#dddddd', # LightGray
1129 :     M => '#dddddd', # LightGray
1130 :    
1131 :     C => '#ffff00', # Yellow
1132 :     U => '#ffff00', # Yellow
1133 :    
1134 :     W => '#ddaa22', # Goldenrod
1135 :     F => '#ddaa22', # Goldenrod
1136 :     Y => '#ddaa22', # Goldenrod
1137 :    
1138 :     K => '#00bbff', # DeepSkyBlue
1139 :     R => '#00bbff', # DeepSkyBlue
1140 :     H => '#44eedd', # Turquoise
1141 :    
1142 :     N => '#99ff99', # PaleGreen
1143 :     Q => '#99ff99', # PaleGreen
1144 :     S => '#99ff99', # PaleGreen
1145 :     T => '#99ff99', # PaleGreen
1146 : golsen 1.1
1147 : golsen 1.4 P => '#aaddaa', # DullGreen
1148 : golsen 1.1
1149 : golsen 1.4 D => '#ff8877', # Salmon
1150 :     E => '#ff8877', # Salmon
1151 : golsen 1.1 );
1152 :     }
1153 :    
1154 :     foreach ( keys %colors ) { $colors{ lc $_ } = $colors{ $_ } }
1155 :    
1156 :     return \%colors;
1157 :     }
1158 :    
1159 :    
1160 :     #-------------------------------------------------------------------------------
1161 :     # \%character_color_pallet = nt_colors() # Default
1162 :     # \%character_color_pallet = nt_colors( $set_name ) # ale | gde
1163 :     #-------------------------------------------------------------------------------
1164 :     sub nt_colors
1165 :     {
1166 :     my $pallet = shift || '';
1167 :     my %colors;
1168 :    
1169 :     if ( $pallet =~ /ale/i )
1170 :     {
1171 :     %colors = (
1172 : golsen 1.4 ' ' => '#666666', # DimGray
1173 :     '~' => '#666666', # DimGray
1174 :     '-' => '#bbbbbb', # Gray
1175 :     '.' => '#888888', # Gray51
1176 :    
1177 :     A => '#ffdd00', # Gold
1178 :     C => '#00ffff', # Cyan
1179 :     G => '#ffff00', # Yellow
1180 :     T => '#99ff99', # PaleGreen
1181 :     U => '#99ff99', # PaleGreen
1182 : golsen 1.1 );
1183 :     }
1184 :     elsif ( $pallet =~ /gde/i )
1185 :     {
1186 :     %colors = (
1187 : golsen 1.4 ' ' => '#666666', # DimGray
1188 :     '~' => '#666666', # DimGray
1189 :     '-' => '#bbbbbb', # Gray
1190 :     '.' => '#888888', # Gray51
1191 :    
1192 :     A => '#ff0000', # Red
1193 :     C => '#0000ff', # Blue
1194 :     G => '#ffff88', # PaleYellow
1195 :     T => '#00ff00', # Green
1196 :     U => '#00ff00', # Green
1197 : golsen 1.1 );
1198 :     }
1199 :     else
1200 :     {
1201 :     %colors = (
1202 : golsen 1.4 ' ' => '#777777',
1203 :     '~' => '#777777',
1204 :     '-' => '#bbbbbb',
1205 :     '.' => '#888888',
1206 :    
1207 :     A => '#ff6666',
1208 :     G => '#ffff00',
1209 :     C => '#00ff00',
1210 :     T => '#8888ff',
1211 :     U => '#8888ff',
1212 :    
1213 :     R => '#ffaa44',
1214 :     Y => '#44dd88',
1215 :     K => '#bbbb99',
1216 :     M => '#eeee66',
1217 :     S => '#aaff55',
1218 :     W => '#cc88cc',
1219 :    
1220 :     B => '#bbdddd',
1221 :     H => '#bbbbdd',
1222 :     D => '#ddbbdd',
1223 :     V => '#ddddaa',
1224 : golsen 1.1
1225 : golsen 1.4 N => '#dddddd',
1226 : golsen 1.1 );
1227 :     }
1228 :    
1229 :     foreach ( keys %colors ) { $colors{ lc $_ } = $colors{ $_ } }
1230 :    
1231 :     return \%colors;
1232 :     }
1233 :    
1234 :    
1235 :     #-------------------------------------------------------------------------------
1236 :     # Return a string for adding an onMouseover tooltip handler:
1237 :     #
1238 :     # mouseover( $title, $text, $menu, $parent, $titlecolor, $bodycolor)
1239 :     #
1240 :     # The code here is virtually identical to that in FIGjs.pm, but makes this
1241 :     # SEED independent.
1242 :     #-------------------------------------------------------------------------------
1243 :     sub mouseover
1244 :     {
1245 :     if ( $have_FIGjs ) { return &FIGjs::mouseover( @_ ) }
1246 :    
1247 : golsen 1.3 my ( $title, $text, $menu, $parent, $titlecolor, $bodycolor ) = @_;
1248 : golsen 1.1
1249 :     defined( $title ) or $title = '';
1250 :     $title =~ s/'/\\'/g; # escape '
1251 :     $title =~ s/"/&quot;/g; # escape "
1252 :    
1253 :     defined( $text ) or $text = '';
1254 :     $text =~ s/'/\\'/g; # escape '
1255 :     $text =~ s/"/&quot;/g; # escape "
1256 :    
1257 :     defined( $menu ) or $menu = '';
1258 :     $menu =~ s/'/\\'/g; # escape '
1259 :     $menu =~ s/"/&quot;/g; # escape "
1260 :    
1261 : golsen 1.3 $parent = '' if ! defined $parent;
1262 :     $titlecolor = '' if ! defined $titlecolor;
1263 :     $bodycolor = '' if ! defined $bodycolor;
1264 :    
1265 : golsen 1.1 qq( onMouseover="javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this,'$title','$text','$menu','$parent','$titlecolor','$bodycolor');this.tooltip.addHandler(); return false;" );
1266 :     }
1267 :    
1268 :    
1269 :     #-------------------------------------------------------------------------------
1270 :     # Return a text string with the necessary JavaScript for the mouseover
1271 :     # tooltips.
1272 :     #
1273 :     # $html = mouseover_JavaScript()
1274 :     #
1275 :     # The code here is virtually identical to that in FIGjs.pm, but makes this
1276 :     # SEED independent.
1277 :     #-------------------------------------------------------------------------------
1278 :     sub mouseover_JavaScript
1279 :     {
1280 :     if ( $have_FIGjs ) { return &FIGjs::toolTipScript( ) }
1281 :    
1282 :     return <<'End_of_JavaScript';
1283 :     <SCRIPT Language='JavaScript'>
1284 :     //
1285 :     // javascript class for tooltips and popup menus
1286 :     //
1287 :     // This class manages the information, creating area to draw tooltips and
1288 :     // popup menus and provides the event handlers to handle them
1289 :     //
1290 :     var DIV_WIDTH=250;
1291 :     var px; // position suffix with "px" in some cases
1292 :     var initialized = false;
1293 :     var ns4 = false;
1294 :     var ie4 = false;
1295 :     var ie5 = false;
1296 :     var kon = false;
1297 :     var iemac = false;
1298 :     var tooltip_name='popup_tooltip_div';
1299 :    
1300 :     function Popup_Tooltip(object, tooltip_title, tooltip_text,
1301 :     popup_menu, use_parent_pos, head_color,
1302 :     body_color) {
1303 :     // The first time an object of this class is instantiated,
1304 :     // we have to setup some browser specific settings
1305 :    
1306 :     if (!initialized) {
1307 :     ns4 = (document.layers) ? true : false;
1308 :     ie4 = (document.all) ? true : false;
1309 :     ie5 = ((ie4) && ((navigator.userAgent.indexOf('MSIE 5') > 0) ||
1310 :     (navigator.userAgent.indexOf('MSIE 6') > 0))) ? true : false;
1311 :     kon = (navigator.userAgent.indexOf('konqueror') > 0) ? true : false;
1312 :     if(ns4||kon) {
1313 :     //setTimeout("window.onresize = function () {window.location.reload();};", 2000);
1314 :     }
1315 :     ns4 ? px="" : px="px";
1316 :     iemac = ((ie4 || ie5) && (navigator.userAgent.indexOf('Mac') > 0)) ? true : false;
1317 :    
1318 :     initialized=true;
1319 :     }
1320 :    
1321 :     if (iemac) { return; } // Give up
1322 :    
1323 :     this.tooltip_title = tooltip_title;
1324 :     this.tooltip_text = tooltip_text;
1325 :    
1326 :     if (head_color) { this.head_color = head_color; }
1327 :     else { this.head_color = "#333399"; }
1328 :    
1329 :     if (body_color) { this.body_color = body_color; }
1330 :     else { this.body_color = "#CCCCFF"; }
1331 :    
1332 :     this.popup_menu = popup_menu;
1333 :     if (use_parent_pos) {
1334 :     this.popup_menu_x = object.offsetLeft;
1335 :     this.popup_menu_y = object.offsetTop + object.offsetHeight + 3;
1336 :     }
1337 :     else {
1338 :     this.popup_menu_x = -1;
1339 :     this.popup_menu_y = -1;
1340 :     }
1341 :    
1342 :     // create the div if necessary
1343 :     // the div may be shared between several instances
1344 :     // of this class
1345 :    
1346 :     this.div = getDiv(tooltip_name);
1347 :     if (! this.div) {
1348 :     // create a hidden div to contain the information
1349 :     this.div = document.createElement("div");
1350 :     this.div.id=tooltip_name;
1351 :     this.div.style.position="absolute";
1352 :     this.div.style.zIndex=0;
1353 :     this.div.style.top="0"+px;
1354 :     this.div.style.left="0"+px;
1355 :     this.div.style.visibility=ns4?"hide":"hidden";
1356 :     this.div.tooltip_visible=0;
1357 :     this.div.menu_visible=0
1358 :     document.body.appendChild(this.div);
1359 :     }
1360 :    
1361 :     // register methods
1362 :    
1363 :     this.showTip = showTip;
1364 :     this.hideTip = hideTip;
1365 :     this.fillTip = fillTip;
1366 :     this.showMenu = showMenu;
1367 :     this.hideMenu = hideMenu;
1368 :     this.fillMenu = fillMenu;
1369 :     this.addHandler = addHandler;
1370 :     this.delHandler = delHandler;
1371 :     this.mousemove = mousemove;
1372 :     this.showDiv = showDiv;
1373 :    
1374 :     // object state
1375 :    
1376 :     this.attached = object;
1377 :     object.tooltip = this;
1378 :     }
1379 :    
1380 :     function getDiv() {
1381 :     if (ie5 || ie4) { return document.all[tooltip_name]; }
1382 :     else if (document.layers) { return document.layers[tooltip_name]; }
1383 :     else if (document.all) { return document.all[tooltip_name]; }
1384 :     return document.getElementById(tooltip_name);
1385 :     }
1386 :    
1387 :     function hideTip() {
1388 :     if (this.div.tooltip_visible) {
1389 :     this.div.innerHTML="";
1390 :     this.div.style.visibility=ns4?"hide":"hidden";
1391 :     this.div.tooltip_visible=0;
1392 :     }
1393 :     }
1394 :    
1395 :     function hideMenu() {
1396 :     if (this.div && this.div.menu_visible) {
1397 :     this.div.innerHTML="";
1398 :     this.div.style.visibility=ns4?"hide":"hidden";
1399 :     this.div.menu_visible=0;
1400 :     }
1401 :     }
1402 :    
1403 :     function fillTip() {
1404 :     this.hideTip();
1405 :     this.hideMenu();
1406 :     if (this.tooltip_title && this.tooltip_text) {
1407 :     this.div.innerHTML='<table width='+DIV_WIDTH+' border=0 cellpadding=2 cellspacing=0 bgcolor="'+this.head_color+'"><tr><td class="tiptd"><table width="100%" border=0 cellpadding=0 cellspacing=0><tr><th><span class="ptt"><b><font color="#FFFFFF">'+this.tooltip_title+'</font></b></span></th></tr></table><table width="100%" border=0 cellpadding=2 cellspacing=0 bgcolor="'+this.body_color+'"><tr><td><span class="pst"><font color="#000000">'+this.tooltip_text+'</font></span></td></tr></table></td></tr></table>';
1408 :     this.div.tooltip_visible=1;
1409 :     }
1410 :     }
1411 :    
1412 :     function fillMenu() {
1413 :     this.hideTip();
1414 :     this.hideMenu();
1415 :     if (this.popup_menu) {
1416 :     this.div.innerHTML='<table cellspacing="2" cellpadding="1" bgcolor="#000000"><tr bgcolor="#eeeeee"><td><div style="max-height:300px;min-width:100px;overflow:auto;">'+this.popup_menu+'</div></td></tr></table>';
1417 :     this.div.menu_visible=1;
1418 :     }
1419 :     }
1420 :    
1421 :     function showDiv(x,y) {
1422 :     winW=(window.innerWidth)? window.innerWidth+window.pageXOffset-16 :
1423 :     document.body.offsetWidth-20;
1424 :     winH=(window.innerHeight)?window.innerHeight+window.pageYOffset :
1425 :     document.body.offsetHeight;
1426 :     if (window.getComputedStyle) {
1427 :     current_style = window.getComputedStyle(this.div,null);
1428 :     div_width = parseInt(current_style.width);
1429 :     div_height = parseInt(current_style.height);
1430 :     }
1431 :     else {
1432 :     div_width = this.div.offsetWidth;
1433 :     div_height = this.div.offsetHeight;
1434 :     }
1435 :     this.div.style.left=(((x + div_width) > winW) ? winW - div_width : x) + px;
1436 :     this.div.style.top=(((y + div_height) > winH) ? winH - div_height: y) + px;
1437 :     // this.div.style.color = "#eeeeee";
1438 :     this.div.style.visibility=ns4?"show":"visible";
1439 :     }
1440 :    
1441 :     function showTip(e,y) {
1442 :     if (!this.div.menu_visible) {
1443 :     if (!this.div.tooltip_visible) {
1444 :     this.fillTip();
1445 :     }
1446 :     var x;
1447 :     if (typeof(e) == 'number') {
1448 :     x = e;
1449 :     }
1450 :     else {
1451 :     x=e.pageX?e.pageX:e.clientX?e.clientX:0;
1452 :     y=e.pageY?e.pageY:e.clientY?e.clientY:0;
1453 :     }
1454 :     x+=2; y+=2;
1455 :     this.showDiv(x,y);
1456 :     this.div.tooltip_visible=1;
1457 :     }
1458 :     }
1459 :    
1460 :     function showMenu(e) {
1461 :     if (this.div) {
1462 :     if (!this.div.menu_visible) {
1463 :     this.fillMenu();
1464 :     }
1465 :     var x;
1466 :     var y;
1467 :    
1468 :     // if the menu position was given as parameter
1469 :     // to the constructor, then use that position
1470 :     // or fall back to mouse position
1471 :    
1472 :     if (this.popup_menu_x != -1) {
1473 :     x = this.popup_menu_x;
1474 :     y = this.popup_menu_y;
1475 :     }
1476 :     else {
1477 :     x = e.pageX ? e.pageX : e.clientX ? e.clientX : 0;
1478 :     y = e.pageY ? e.pageY : e.clientY ? e.clientY : 0;
1479 :     }
1480 :     this.showDiv(x,y);
1481 :     this.div.menu_visible=1;
1482 :     }
1483 :     }
1484 :    
1485 :     // Add the event handler to the parent object.
1486 :     // The tooltip is managed by the mouseover and mouseout
1487 :     // events. mousemove is captured, too
1488 :    
1489 :     function addHandler() {
1490 :     if (iemac) { return; } // ignore Ie on mac
1491 :    
1492 :     if(this.tooltip_text) {
1493 :     this.fillTip();
1494 :     this.attached.onmouseover = function (e) {
1495 :     this.tooltip.showTip(e);
1496 :     return false;
1497 :     };
1498 :     this.attached.onmousemove = function (e) {
1499 :     this.tooltip.mousemove(e);
1500 :     return false;
1501 :     };
1502 :     }
1503 :    
1504 :     if (this.popup_menu) {
1505 :     this.attached.onclick = function (e) {
1506 :     this.tooltip.showMenu(e);
1507 :    
1508 :     // reset event handlers
1509 :     if (this.tooltip_text) {
1510 :     this.onmousemove=null;
1511 :     this.onmouseover=null;
1512 :     this.onclick=null;
1513 :     }
1514 :    
1515 :     // there are two mouseout events,
1516 :     // one when the mouse enters the inner region
1517 :     // of our div, and one when the mouse leaves the
1518 :     // div. we need to handle both of them
1519 :     // since the div itself got no physical region on
1520 :     // the screen, we need to catch event for its
1521 :     // child elements
1522 :     this.tooltip.div.moved_in=0;
1523 :     this.tooltip.div.onmouseout=function (e) {
1524 :     var div = getDiv(tooltip_name);
1525 :     if (e.target.parentNode == div) {
1526 :     if (div.moved_in) {
1527 :     div.menu_visible = 0;
1528 :     div.innerHTML="";
1529 :     div.style.visibility=ns4?"hide":"hidden";
1530 :     }
1531 :     else {
1532 :     div.moved_in=1;
1533 :     }
1534 :     return true;
1535 :     };
1536 :     return true;
1537 :     };
1538 :     this.tooltip.div.onclick=function() {
1539 :     this.menu_visible = 0;
1540 :     this.innerHTML="";
1541 :     this.style.visibility=ns4?"hide":"hidden";
1542 :     return true;
1543 :     }
1544 :     return false; // do not follow existing links if a menu was defined!
1545 :    
1546 :     };
1547 :     }
1548 :     this.attached.onmouseout = function () {
1549 :     this.tooltip.delHandler();
1550 :     return false;
1551 :     };
1552 :     }
1553 :    
1554 :     function delHandler() {
1555 :     if (this.div.menu_visible) { return true; }
1556 :    
1557 :     // clean up
1558 :    
1559 :     if (this.popup_menu) { this.attached.onmousedown = null; }
1560 :     this.hideMenu();
1561 :     this.hideTip();
1562 :     this.attached.onmousemove = null;
1563 :     this.attached.onmouseout = null;
1564 :    
1565 :     // re-register the handler for mouse over
1566 :    
1567 :     this.attached.onmouseover = function (e) {
1568 :     this.tooltip.addHandler(e);
1569 :     return true;
1570 :     };
1571 :     return false;
1572 :     }
1573 :    
1574 :     function mousemove(e) {
1575 :     if (this.div.tooltip_visible) {
1576 :     if (e) {
1577 :     x=e.pageX?e.pageX:e.clientX?e.clientX:0;
1578 :     y=e.pageY?e.pageY:e.clientY?e.clientY:0;
1579 :     }
1580 :     else if (event) {
1581 :     x=event.clientX;
1582 :     y=event.clientY;
1583 :     }
1584 :     else {
1585 :     x=0; y=0;
1586 :     }
1587 :    
1588 :     if(document.documentElement) // Workaround for scroll offset of IE
1589 :     {
1590 :     x+=document.documentElement.scrollLeft;
1591 :     y+=document.documentElement.scrollTop;
1592 :     }
1593 :     this.showTip(x,y);
1594 :     }
1595 :     }
1596 :    
1597 :     function setValue(id , val) {
1598 :     var element = document.getElementById(id);
1599 :     element.value = val;
1600 :     }
1601 :    
1602 :     </SCRIPT>
1603 :     End_of_JavaScript
1604 :     }
1605 :    
1606 :    
1607 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3