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

Annotation of /FigKernelPackages/gjoalign2html.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3