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

Annotation of /FigKernelPackages/gjoalign2html.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3