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

Annotation of /FigKernelPackages/gd_tree_0.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : golsen 1.1 # -*- perl -*-
2 :     ########################################################################
3 :     # Copyright (c) 2003-2009 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 :     package gd_tree;
20 :    
21 :     # use Data::Dumper;
22 :     # use Carp;
23 :    
24 :     use GD;
25 :     use gjonewicklib;
26 :     use strict;
27 :    
28 :     # my $string = '((A:1,B:2):3,(C:2,M:4):2);';
29 :     # my $tree = parse_newick_tree_str( $string );
30 :     # newick_gd_png( $tree, { bkg_color => [255,255,0] } );
31 :    
32 :     #===============================================================================
33 :     # newick_gd_png( $node, \%options )
34 :     #===============================================================================
35 :     sub newick_gd_png
36 :     {
37 :     my ( $tree, $options ) = @_;
38 :    
39 : golsen 1.2 $options ||= {};
40 :     my $file = $options->{ file };
41 :     my $fh;
42 :     if ( ! $file ) { $fh = \*STDOUT }
43 :     elsif ( ref( $file ) eq 'GLOB' ) { $fh = $file }
44 :     else
45 :     {
46 :     open( $fh, ">$file" )
47 :     or print STERR "Could not open $file.\n" and return 0;
48 :     }
49 :    
50 : golsen 1.1 my $image = gd_plot_newick( $tree, $options );
51 :    
52 : golsen 1.2 print $fh $image->png;
53 :    
54 :     close( $fh ) if $file && ! ref( $file );
55 :     return 1;
56 : golsen 1.1 }
57 :    
58 :    
59 :     #===============================================================================
60 :     # Make a GD plot of a tree:
61 :     #
62 :     # $gd_image = gd_plot_newick( $node, \%options );
63 :     # ( $gd_image, $hash ) = gd_plot_newick( $node, \%options );
64 :     #
65 :     # $node newick tree root node
66 :     #
67 :     # Options:
68 :     #
69 :     # bar_position => position # D = ll (lower_left)
70 :     # bkg_color => [ @RGB ] # D = transparent
71 :     # dy => pixels # vertical spacing (D = 12)
72 :     # font => gb_font_name # D depends size
73 :     # font_size => pixels # synonym for text_size
74 :     # line_color => [ @RGB ] # D = black
75 :     # min_dx => min_node_spacing # D = 0
76 :     # scale_bar => length # D is based on drawing size
77 :     # text_bkg_color => [ @RGB ] # D = none
78 :     # text_color => [ @RGB ] # D = black
79 :     # text_size => pixels # D = 0.8 * dy
80 :     # thickness => pixels # tree line thickness (D = 1)
81 :     # width => pixels # width of tree w/o labels (D = 540)
82 :     # x_scale => pixels_per_unit_x # D is scaled to fit width
83 :     #
84 :     # All color RGB values are on 0-255 color intensity range
85 :     #
86 :     # $hash is a reference to a hash of data about the tree and its layout.
87 :     #
88 :     # $hash->{ $node }->{ lbl_rect } is the coordinates (ul, lr) of the label
89 :     # of node refered to my $node. These can be used to build an image map.
90 :     #
91 :     #===============================================================================
92 :     sub gd_plot_newick
93 :     {
94 :     my ( $node, $options ) = @_;
95 :     array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
96 :    
97 :     # colors will all be [r,g,b] in 0 - 255 range;
98 :     # sizes will all be in pixels
99 :    
100 :     my %options = ref( $options ) eq 'HASH' ? %$options : ();
101 :    
102 :     # Vertical size adjustments:
103 :    
104 :     my ( $dy_key ) = grep { /^dy/i } keys %options;
105 :     $options{ dy } = $dy_key ? $options{ $dy_key } : undef;
106 :    
107 :     # Allow font_size or text_size
108 :    
109 :     my ( $font_size_key ) = grep { /^fo?nt.*si?z/i || /^te?xt.*si?z/i } keys %options;
110 :     $options{ font_size } = $font_size_key ? $options{ $font_size_key } : undef;
111 :    
112 :     adjust_font( \%options ); # This adds options
113 :    
114 :     # Horizontal size adjustments:
115 :    
116 :     my ( $wid_key ) = grep { /^wid/i } keys %options;
117 :     my $width = $options{ width } = $wid_key ? $options{ $wid_key } : 72 * 7.5;
118 :    
119 :     my ( $min_dx_key ) = grep { /dx/i && ! /la?be?l/i } keys %options;
120 :     $options{ min_dx } = $min_dx_key ? $options{ $min_dx_key } : 0;
121 :    
122 :     my $max_x = newick_max_X( $node );
123 :     my ( $x_scale_key ) = grep { /x_?scale/i } keys %options;
124 :     my $x_scale = $options{ $x_scale_key }
125 :     || $width / ( $max_x || 1 );
126 :     $options{ x_scale } = $x_scale;
127 :    
128 :     # Scale bar:
129 :    
130 :     my ( $bar_key ) = grep { /bar/i && ! /pos/i } keys %options;
131 :     my $bar_len = $options{ $bar_key };
132 :     $bar_len = bar_length( $max_x ) if ! defined( $bar_len );
133 :     $options{ bar_len } = $bar_len;
134 :    
135 :     my $bar_pos;
136 :     if ( $bar_len > 0 )
137 :     {
138 :     my ( $bar_pos_key ) = grep { /bar.*pos/i } keys %options;
139 :     my $bar_val = $options{ $bar_pos_key };
140 :     $bar_pos = $bar_val =~ /up.*rig/i ? 'ur' :
141 :     $bar_val =~ /low.*rig/i ? 'lr' :
142 :     $bar_val =~ /up/i ? 'ul' :
143 :     $bar_val =~ /low/i ? 'll' :
144 :     $bar_val =~ /^(ur|ul|lr|ll)$/i ? $bar_val :
145 :     'll';
146 :     $options{ bar_pos } = $bar_pos;
147 :     $options{ bar_font } = $options{ font } || 'gdSmallFont';
148 :     }
149 :    
150 :     # Line adjustment:
151 :    
152 :     my ( $thickness_key ) = grep { /thick/i } keys %options;
153 :     my $thickness = $thickness_key ? $options{ $thickness_key } : 1;
154 :     $thickness = int( $thickness + 0.5 );
155 :     $options{ thickness } = $thickness || 1;
156 :    
157 :     my ( $line_color_key ) = grep { /^lin.*co?lo?r/i } keys %options;
158 :     my $line_color = $line_color_key ? $options{ $line_color_key } : [0,0,0];
159 :     $options{ line_color } = $line_color;
160 :    
161 :     # Other colors:
162 :    
163 :     my ( $bkg_color_key ) = grep { /^b.*k.*g.*co?lo?r/i } keys %options;
164 :     my $bkg_color = $bkg_color_key ? $options{ $bkg_color_key } : undef;
165 :     $options{ bkg_color } = $bkg_color;
166 :    
167 :     my ( $text_color_key ) = grep { /^te?xt.*co?lo?r/i && ! /bkg/ } keys %options;
168 :     my $text_color = $text_color_key ? $options{ $text_color_key } : [0,0,0];
169 :     $options{ text_color } = $text_color;
170 :    
171 :     my ( $text_bkg_color_key ) = grep { /^te?xt.*bkg.*co?lo?r/i } keys %options;
172 :     my $text_bkg_color = $text_bkg_color_key ? $options{ $text_bkg_color_key } : undef;
173 :     $options{ text_bkg_color } = $text_bkg_color;
174 :    
175 :     my $hash = {};
176 :     my $dy = $options{ dy };
177 :     layout_gd_tree( $node, $hash, \%options,
178 :     int( 2*$thickness + 0.4999 ), int( 0.5*$dy + 0.4999 )
179 :     );
180 :    
181 :     render_gd_tree( $node, $hash, \%options );
182 :     }
183 :    
184 :    
185 :     sub bar_length
186 :     {
187 :     my ( $max_x ) = @_;
188 :     my $target = 0.4 * $max_x;
189 :     my $e = 10**( int( log($target)/log(10) + 100 ) -100 );
190 :     my $f = $target / $e;
191 :     ( $f >= 10 ? 10 : $f >= 5 ? 5 : $f >= 2 ? 2 : 1 ) * $e;
192 :     }
193 :    
194 :    
195 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
196 :     # ( $root_y, $xmax, $yn ) = layout_gd_tree( $node, $hash, $options, $x0, $y0, $parent )
197 :     #
198 :     # GD coordinate 0,0 is upper left corner
199 :     #
200 :     # $hash->{ $node } = { x0 => $x0, x => $x, y => $y, y1 => $y1, y2 => $y2,
201 :     # xmax => $xmax, y0 => $y0, yn => $yn
202 :     # }
203 :     #
204 :     # y0 _ _ _ _ _ _ _ _ _ _ _ _ _ _
205 :     # +----------+ label_1
206 :     # y1 - - - - +---+
207 :     # | +----+ label_2
208 :     # y - - +----+
209 :     # | +------+ label_3
210 :     # y2 - -|- - +----+
211 :     # | | +--------+ label_4
212 :     # | | +---+ |
213 :     # yn _ _|_ _ |_ _ _ _ +---+ label_5
214 :     # | | |
215 :     # x0 x xmax
216 :     #
217 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
218 :     sub layout_gd_tree
219 :     {
220 :     my ( $node, $hash, $options, $x0, $y0, $parent ) = @_;
221 :     array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
222 :     hash_ref( $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
223 :    
224 :     my $x_scale = $options->{ x_scale };
225 :     my $min_dx = $options->{ min_dx };
226 :     my $dy = $options->{ dy };
227 :    
228 :     my $dx = gjonewicklib::newick_x( $node );
229 :     if ( defined( $dx ) )
230 :     {
231 :     $dx *= $x_scale;
232 :     $dx >= $min_dx or $dx = $min_dx;
233 :     }
234 :     else
235 :     {
236 :     $dx = $parent ? $min_dx : 0;
237 :     }
238 :     $dx = int( $dx + 0.4999 );
239 :    
240 :     my ( $x, $y, $y1, $y2, $xmax, $yn );
241 :    
242 :     $x = $x0 + $dx;
243 :     my @dl = gjonewicklib::newick_desc_list( $node );
244 :    
245 :     if ( ! @dl ) # A tip
246 :     {
247 :     $xmax = $x;
248 :     $y = $y1 = $y2 = int( $y0 + 0.5 * $dy + 0.4999 );
249 :     $yn = $y0 + $dy;
250 :     }
251 :     else # A subtree
252 :     {
253 :     $xmax = -1e100;
254 :     my $xmaxi;
255 :     my $yi;
256 :     my @nodelist = ();
257 :     $yn = $y0;
258 :    
259 :     foreach ( @dl )
260 :     {
261 :     push @nodelist, $_;
262 :     ( $yi, $xmaxi, $yn ) = layout_gd_tree( $_, $hash, $options, $x, $yn, $node );
263 :     if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
264 :     }
265 :    
266 :     # Use of nodelist is overkill for saving first and last values,
267 :     # but eases implimentation of alternative y-value calculations.
268 :    
269 :     $y1 = $hash->{ $nodelist[ 0] }->{ y };
270 :     $y2 = $hash->{ $nodelist[-1] }->{ y };
271 :     $y = int( 0.5 * ( $y1 + $y2 ) + 0.4999 );
272 :     }
273 :    
274 :     $hash->{ $node } = { x0 => $x0, x => $x, y => $y, y1 => $y1, y2 => $y2,
275 :     xmax => $xmax, y0 => $y0, yn => $yn,
276 :     parent => $parent
277 :     };
278 :    
279 :     # Scan comment 1 for embedded format information:
280 :    
281 :     my $c1 = gjonewicklib::newick_c1( $node );
282 :     my %c1 = ();
283 :     foreach ( grep { s/^&&gdTree:\s*// || s/^&&treeLayout:\s*// }
284 :     ( ref $c1 eq 'ARRAY' ? @$c1 : ( $c1 ) ) # $c1 should be an array ref, but allow a string
285 :     )
286 :     {
287 :     my @data = map { /(\S+)\s*=>?\s*\[\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*\]/ ? [ $1, [$2,$3,$4] ] : # color
288 :     /(\S+)\s*=>?\s*(\S+)/ ? [ $1, $2 ] : # other key=value
289 :     ()
290 :     } split /\s*;\s*/, $_;
291 :     foreach ( @data ) { $c1{ $_->[0] } = $_->[1] }
292 :     }
293 :    
294 :     $hash->{ $node }->{ inherit } = \%c1 if keys %c1;
295 :    
296 :     ( $y, $xmax, $yn );
297 :     }
298 :    
299 :    
300 :     #
301 :     # $image = render_gd_tree( $node, $hash, $options )
302 :     #
303 :     sub render_gd_tree
304 :     {
305 :     my ( $node, $hash, $options ) = @_;
306 :    
307 :     my $nodeinfo = $hash->{ $node };
308 :     my $xmax = pict_width( $node, $hash, $options );
309 :     $options->{ xmax } = $xmax;
310 :    
311 :     # Start a new image
312 :    
313 :     my $ymax = int( $nodeinfo->{ yn } + 0.5 * $options->{ dy } + 0.4999 );
314 :     $options->{ ymax } = $ymax;
315 :     my @size = ( $xmax + 1, $ymax + 1 );
316 :     my $image = new GD::Image( @size );
317 :     $image->trueColor( 1 );
318 :    
319 :     # Background is done outside of my management:
320 :    
321 :     my $bkg;
322 :     if ( $options->{ bkg_color } )
323 :     {
324 :     $bkg = $image->colorAllocate( @{ $options->{ bkg_color } } );
325 :     }
326 :     else
327 :     {
328 :     $bkg = $image->colorAllocate( 255, 255, 255 );
329 :     $image->transparent( $bkg );
330 :     }
331 :     $options->{ bkg_index } = $bkg;
332 :    
333 :     # Draw the tree
334 :    
335 :     render_gd_tree2( $image, $node, $hash, $options );
336 :    
337 :     # Scale bar; oh bother:
338 :    
339 :     if ( $options->{ bar_pos } && $options->{ bar_font } )
340 :     {
341 :     my $bar_pos = $options->{ bar_pos };
342 :     my $bar_len = int( $options->{ bar_len } * $options->{ x_scale } + 0.5 );
343 :     my ( $x1, $x2, $y, $lo );
344 :     if ( $bar_pos =~ /^.l$/i )
345 :     {
346 :     $x1 = $nodeinfo->{ x0 };
347 :     $x2 = $x1 + $bar_len;
348 :     }
349 :     else
350 :     {
351 :     $x1 = $nodeinfo->{ xmax } - 2 * $options->{ thickness };
352 :     $x2 = $x1 - $bar_len;
353 :     }
354 :     my $lbl_x = int( 0.5*($x1+$x2+1) );
355 :     if ( $bar_pos =~ /^u.$/i )
356 :     {
357 :     $y = $nodeinfo->{ y0 };
358 :     $lo = 16;
359 :     }
360 :     else
361 :     {
362 :     $y = $nodeinfo->{ yn };
363 :     $lo = 14;
364 :     }
365 :    
366 :     $image->setThickness( $options->{ thickness } );
367 :     my $line_color = myGetColor( $image, $options->{ line_color } );
368 :     $image->line( $x1, $y, $x2, $y, $line_color );
369 :    
370 :     my $text_color = myGetColor( $image, $options->{ text_color } );
371 :     my $opt = { text_color => $text_color,
372 :     label_origin => $lo
373 :     };
374 :     gdPlacedText( $image, "$options->{bar_len}", $options->{ bar_font }, $lbl_x, $y, $opt );
375 :     }
376 :    
377 :     wantarray ? ( $image, $hash ) : $image;
378 :     }
379 :    
380 :    
381 :     #
382 :     # $image = render_gd_tree2( $image, $node, $hash, $options )
383 :     #
384 :     sub render_gd_tree2
385 :     {
386 :     my ( $image, $node, $hash, $options ) = @_;
387 :    
388 :     my $nodeinfo = $hash->{ $node };
389 :    
390 :     # Are there localized options?
391 :    
392 :     if ( ref $nodeinfo->{ inherit } eq 'HASH' )
393 :     {
394 :     $options = { %$options };
395 :     foreach ( keys %{ $nodeinfo->{ inherit } } )
396 :     {
397 :     $options->{ $_ } = $nodeinfo->{ inherit }->{ $_ };
398 :     }
399 :     }
400 :    
401 :     my $x0 = $nodeinfo->{ x0 };
402 :     my $x = $nodeinfo->{ x };
403 :     my $y = $nodeinfo->{ y };
404 :    
405 :     if ( $nodeinfo->{ inherit }->{ bkg_color } )
406 :     {
407 :     my $x1 = max( int( 0.5*($x0+$x+1)), $x0+1 );
408 :     my $xmax = $options->{ xmax };
409 :     my $y0 = $nodeinfo->{ y0 };
410 :     my $yn = $nodeinfo->{ yn };
411 :     my $bkg_color = myGetColor( $image, $nodeinfo->{ inherit }->{ bkg_color } );
412 :     $image->setThickness( 1 );
413 :     $image->filledRectangle( $x1, $y0, $xmax, $yn, $bkg_color );
414 :     }
415 :    
416 :     $image->setThickness( $options->{ thickness } );
417 :     my $line_color = myGetColor( $image, $options->{ line_color } );
418 :    
419 :     my @dl = gjonewicklib::newick_desc_list( $node );
420 :     if ( ! @dl ) # A tip
421 :     {
422 :     $image->line( $x0, $y, $x, $y, $line_color );
423 :     my $lbl = gjonewicklib::newick_lbl( $node );
424 :     my $font_size = $options->{ font_size };
425 :     if ( $lbl && $font_size )
426 :     {
427 :     my $lbl_x = $x + $options->{ lbl_dx };
428 :     my $font = $options->{ font };
429 :     my $text_color = myGetColor( $image, $options->{ text_color } );
430 :     my $text_bkg = $options->{ text_bkg_color };
431 :     my $text_bkg_color = $text_bkg ? myGetColor( $image, $text_bkg ) : undef;
432 :     my @rectangle = ();
433 :     if ( $font )
434 :     {
435 :     my $opt = { text_color => $text_color,
436 :     ( $text_bkg_color ? ( text_bkg_color => $text_bkg_color ) : () ),
437 :     # text_border => 1,
438 :     label_origin => 2
439 :     };
440 :     @rectangle = gdPlacedText( $image, $lbl, $font, $lbl_x, $y, $opt );
441 :     }
442 :     else
443 :     {
444 :     my $len = int( 0.5 * $font_size * length( $lbl ) + 0.5 );
445 :     my $thick = $options->{ lbl_line };
446 :     @rectangle = ( $lbl_x, int( $y - 0.5*$thick ),
447 :     $lbl_x + $len, int( $y + 0.5*$thick )
448 :     );
449 :     $image->setThickness( $thick );
450 :     $image->line( $lbl_x, $y, $lbl_x+$len, $y, $text_bkg_color || $text_color );
451 :     }
452 :     $nodeinfo->{ lbl_rect } = \@rectangle;
453 :     }
454 :     }
455 :     else
456 :     {
457 :     $image->line( $nodeinfo->{ x0 }, $y, $x, $y, $line_color );
458 :     $image->line( $x, $nodeinfo->{ y1 }, $x, $nodeinfo->{ y2 }, $line_color );
459 :    
460 :     foreach ( @dl ) { render_gd_tree2( $image, $_, $hash, $options ) }
461 :     }
462 :    
463 :     $image
464 :     }
465 :    
466 :    
467 :     sub pict_width
468 :     {
469 :     my ( $node, $hash, $options ) = @_;
470 :     return $hash->{ xmax } if ( $options->{ font_size } < 1 );
471 :    
472 :     my $xmax;
473 :     my @dl = gjonewicklib::newick_desc_list( $node );
474 :     if ( ! @dl )
475 :     {
476 :     $xmax = $hash->{ $node }->{ x };
477 :     my $lbl = gjonewicklib::newick_lbl( $node );
478 :     if ( $lbl )
479 :     {
480 :     $xmax += $options->{ lbl_dx } + 2;
481 :     my $font = $options->{ font };
482 :     if ( $font )
483 :     {
484 :     $xmax += textWidth( $lbl, $font );
485 :     }
486 :     else
487 :     {
488 :     $xmax += int( 0.5 * $options->{ font_size } * length( $lbl ) + 0.9999 );
489 :     }
490 :     }
491 :     }
492 :     else
493 :     {
494 :     $xmax = -1e100;
495 :     foreach ( @dl )
496 :     {
497 :     my $x = pict_width( $_, $hash, $options );
498 :     $xmax = $x if $x > $xmax;
499 :     }
500 :    
501 :     }
502 :    
503 :     $xmax
504 :     }
505 :    
506 :    
507 :     #===============================================================================
508 :     # A subroutine to simplify the placing of text strings in the GD environment.
509 :     # The model is based upon label origin (LO) in HPGL.
510 :     #
511 :     # 13 16 19
512 :     #
513 :     #
514 :     # 3TTTTTTTTT EEEEEEEEEE 6XX XX TTTTTTTTT9
515 :     # TT EE XX XX TT
516 :     # TT EE XX XX TT
517 :     # 12 2 TT EEEEEEEE 5 X TT 8 18
518 :     # TT EE XX XX TT
519 :     # TT EE XX XX TT
520 :     # 1 TT EEEEEEEEEE 4XX XX TT 7
521 :     #
522 :     #
523 :     # 11 14 17
524 :     #
525 :     #
526 :     # GD has an odd font position model. For example, for gdSmallFont:
527 :     # __________________________________________________________________________
528 :     # |O <- string origin point ^ ^
529 :     # | top lead = 3 |
530 :     # | _______________v_______________ |
531 :     # | XX XXXXXX ^ |
532 :     # | XX XX XX XX _________ | |
533 :     # | XXXXXX XXXX XX XX XXXX XX ^ upper font
534 :     # |XX XX XX XXXX XXXX XX XX XX lower case height
535 :     # |XX XX XX XX XX XX XX XX case rise = 13
536 :     # | XXXXXX XX XX XX XX XX XX rise = 8 |
537 :     # |XX XX XXXX XX XX XX XX XX = 6 | |
538 :     # | XXXXXX | XXXX XX XXXXXX XX XX_____v________v____ |
539 :     # |XX XX | descent = 2 |
540 :     # |_ XXXXXX __|___________________________________________v_____________v___
541 :     # | |
542 :     # |<- width ->|
543 :     # | = 6 |
544 :     #
545 :     #-------------------------------------------------------------------------------
546 :     # Block to ensure that font description hash is loaded
547 :     #-------------------------------------------------------------------------------
548 :    
549 :     BEGIN {
550 :    
551 :     my %fontData =
552 :     # font font cell cell top uc lc des-
553 :     # name object width height lead rise rise cent
554 :     ( gdTinyFont => [ gdTinyFont, 5, 8, 1, 6, 4, 1 ],
555 :     gdSmallFont => [ gdSmallFont, 6, 13, 3, 8, 6, 2 ],
556 :     gdLargeFont => [ gdLargeFont, 8, 16, 3, 10, 7, 3 ],
557 :     gdMediumBoldFont => [ gdMediumBoldFont, 7, 13, 2, 9, 6, 2 ],
558 :     gdGiantFont => [ gdGiantFont, 9, 15, 3, 10, 7, 2 ]
559 :     );
560 :    
561 :    
562 :     sub adjust_font
563 :     {
564 :     my ( $options ) = @_;
565 :    
566 :     my $dy = $options->{ dy };
567 :     my $font_size = $options->{ font_size };
568 :    
569 :     my ( $font_key ) = grep { /^font/i && ! ( /si?ze/i ) && ! ( /co?lo?r/i ) } keys %$options;
570 :     my $font = $fontData{ $options->{ $font_key } } ? $options->{ $font_key }
571 :     : undef;
572 :    
573 :     if ( ! defined( $dy ) )
574 :     {
575 :     if ( ! $font )
576 :     {
577 :     $font = defined( $font_size ) ? fontFromSize( $font_size )
578 :     : 'gdSmallFont';
579 :     }
580 :     $font_size = $fontData{$font}->[4] + $fontData{$font}->[6] if $font;
581 :     $dy = max( int( 1.2 * $font_size + 0.5 ), 2 );
582 :     }
583 :     else
584 :     {
585 :     $dy = max( int( $dy + 0.5 ), 2 );
586 :     if ( $font )
587 :     {
588 :     $font_size = $fontData{$font}->[4] + $fontData{$font}->[6];
589 :     }
590 :     else
591 :     {
592 :     $font_size = int( 0.85 * $dy ) if ! defined( $font_size );
593 :     $font = fontFromSize( $font_size );
594 :     $font_size = $fontData{$font}->[4] + $fontData{$font}->[6] if $font;
595 :     }
596 :     }
597 :     $options->{ dy } = $dy;
598 :     $options->{ font_size } = $font_size;
599 :     $options->{ font } = $font;
600 :    
601 :     my $char_width;
602 :     if ( $font )
603 :     {
604 :     $char_width = $fontData{$font}->[1];
605 :     $options->{ lbl_dx } = int( 1.5 * $char_width );
606 :     }
607 :     else
608 :     {
609 :     $char_width = 0.5 * $font_size;
610 :     $options->{ lbl_dx } = int( $font_size + 1 );
611 :     $options->{ lbl_line } = int( 0.6 * $font_size + 0.5 );
612 :     }
613 :     $options->{ char_width } = $char_width;
614 :    
615 :     ( $dy, $font_size, $font )
616 :     }
617 :    
618 :    
619 :     sub fontFromSize
620 :     {
621 :     my ( $font_size ) = @_;
622 :    
623 :     return $font_size < 6 ? undef
624 :     : $font_size < 10 ? 'gdTinyFont'
625 :     : $font_size < 13 ? 'gdSmallFont'
626 :     : 'gdLargeFont';
627 :     }
628 :    
629 :    
630 :     sub textWidth
631 :     {
632 :     my ( $text, $fontname, $extra_chr ) = @_;
633 :     $text && $fontname && $fontData{ $fontname }
634 :     or return undef;
635 :     $fontData{ $fontname }->[1] * ( length( $text ) + ( $extra_chr || 0 ) );
636 :     }
637 :    
638 :    
639 :     sub gdPlacedText
640 :     {
641 :     my ( $image, $text, $fontname, $x0, $y0, $options ) = @_;
642 :     $image && $text && $fontname && $fontData{ $fontname }
643 :     && defined $x0 && defined $y0
644 :     or return undef;
645 :     $options = {} unless hash_ref( $options );
646 :     my ( $text_color );
647 :     if ( $options->{ text_color } )
648 :     {
649 :     $text_color = $options->{ text_color }
650 :     }
651 :     else
652 :     {
653 :     $text_color = $image->colorAllocate( 0, 0, 0 );
654 :     }
655 :     my $text_bkg_color = $options->{ text_bkg_color };
656 :     my $textBorder = $options->{ text_border };
657 :     $textBorder = 1 unless defined $textBorder;
658 :    
659 :     my ( $font, $fWidth, $fHeight, $fLead, $ucRise, $lcRise, $fDescent )
660 :     = @{ $fontData{ $fontname } };
661 :    
662 :     my $label_origin = int( $options->{ label_origin } || 1 );
663 :     return if $label_origin < 1 || $label_origin > 19 || $label_origin == 10;
664 :    
665 :     # Adjust vertical position:
666 :    
667 :     my @v_offset = ( undef, 2, 1, 0, 2, 1, 0, 2, 1, 0,
668 :     undef, 3, 1, -1, 3, 1, -1, 3, 1, -1 );
669 :     $y0 -= $fLead + int( 0.5 * $v_offset[ $label_origin ] * $ucRise );
670 :    
671 :     # Adjust horizontal position:
672 :    
673 :     my $textWidth = length( $text ) * $fWidth;
674 :     my @h_offset = ( undef, 0, 0, 0, 0, 0, 0, 0, 0, 0,
675 :     undef, -1, -1, -1, 0, 0, 0, 1, 1, 1 );
676 :     $x0 -= int( 0.5 * $h_offset[ $label_origin ] * $ucRise
677 :     + ( $label_origin >= 17 ? $textWidth :
678 :     $label_origin >= 14 ? $textWidth / 2 :
679 :     0
680 :     )
681 :     );
682 :     my @rect = ( $x0-$textBorder, $y0+$fLead-$textBorder,
683 :     $x0+$textWidth+$textBorder-2, $y0+$fHeight+$textBorder-1 );
684 :     if ( $text_bkg_color )
685 :     {
686 :     $image->filledRectangle( @rect, $text_bkg_color );
687 :     }
688 :     $image->string( $font, $x0, $y0, $text, $text_color);
689 :    
690 :     @rect; # Return the rectangle
691 :     }
692 :     } # End of BEGIN block
693 :    
694 :    
695 :     # We can pretty quickly manage colors without worrying about the GD limits.
696 :     # Generally the idea is to not free any colors. Just let automatic recycling
697 :     # take over if necessary.
698 :    
699 :     BEGIN
700 :     {
701 :     my %colorIndex = ();
702 :     my %indexColor = ();
703 :     my @recycleStack = ();
704 :     my $n_allo = 0;
705 :     my $n_stable = 64;
706 :     my %is_stable = ();
707 :    
708 :     sub myGetColor
709 :     {
710 :     my $image = shift;
711 :     my ( @RGB ) = map { $_ || 0 } ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
712 :     my $name = sprintf '%03d.%03d.%03d', @RGB;
713 :     return $colorIndex{ $name } if $colorIndex{ $name };
714 :     if ( $n_allo > 250 )
715 :     {
716 :     my ( $del_name, $free_index ) = @{ shift @recycleStack };
717 :     $image->colorDeallocate( $free_index );
718 :     delete $colorIndex{ $del_name };
719 :     delete $indexColor{ $free_index };
720 :     $n_allo--;
721 :     }
722 :     my $index = $image->colorAllocate( @RGB );
723 :     $colorIndex{ $name } = $index;
724 :     $indexColor{ $index } = $name;
725 :     if ( ++$n_allo > $n_stable )
726 :     {
727 :     push @recycleStack, [ $name, $index ];
728 :     }
729 :     else
730 :     {
731 :     $is_stable{ $index } = 1;
732 :     }
733 :    
734 :     $index;
735 :     }
736 :    
737 :     sub myFreeColor
738 :     {
739 :     my ( $image, $index ) = @_;
740 :     my $name = $indexColor{ $index };
741 :     return unless $name;
742 :    
743 :     if ( $is_stable{ $index } )
744 :     {
745 :     delete $is_stable{ $index };
746 :     if ( @recycleStack )
747 :     {
748 :     $is_stable{ $recycleStack[0]->[1] } = 1;
749 :     shift @recycleStack;
750 :     }
751 :     }
752 :     else
753 :     {
754 :     @recycleStack = grep { $_->[1] != $index } @recycleStack;
755 :     }
756 :    
757 :     $image->colorDeallocate( $index );
758 :     delete $colorIndex{ $name };
759 :     delete $indexColor{ $index };
760 :     $n_allo--;
761 :     }
762 :    
763 :     }
764 :    
765 :    
766 :     sub min { $_[0] < $_[1] ? $_[0] : $_[1] }
767 :     sub max { $_[0] > $_[1] ? $_[0] : $_[1] }
768 :     sub array_ref { ref $_[0] eq 'ARRAY' }
769 :     sub hash_ref { ref $_[0] eq 'HASH' }
770 :    
771 :    
772 :     1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3