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

Annotation of /FigKernelPackages/gjoalign2html.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3