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

Annotation of /FigKernelPackages/gjoalign2html.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3