File Coverage

blib/lib/Bio/Phylo/Treedrawer/Svg.pm
Criterion Covered Total %
statement 77 161 47.8
branch 13 38 34.2
condition 8 54 14.8
subroutine 16 20 80.0
pod n/a
total 114 273 41.7


line stmt bran cond sub pod time code
1             package Bio::Phylo::Treedrawer::Svg;
2 2     2   12 use strict;
  2         4  
  2         58  
3 2     2   10 use base 'Bio::Phylo::Treedrawer::Abstract';
  2         2  
  2         611  
4 2     2   13 use Bio::Phylo::Util::CONSTANT qw'looks_like_hash _PI_';
  2         4  
  2         92  
5 2     2   10 use Bio::Phylo::Util::Exceptions 'throw';
  2         4  
  2         63  
6 2     2   465 use Bio::Phylo::Util::Dependency 'SVG';
  2         6  
  2         11  
7 2     2   12 use Bio::Phylo::Util::Logger;
  2         4  
  2         1173  
8             SVG->import(
9             '-nocredits' => 1,
10             '-inline' => 1,
11             '-indent' => ' ',
12             );
13             my $logger = Bio::Phylo::Util::Logger->new;
14             my $PI = _PI_;
15             my %colors;
16              
17             =head1 NAME
18              
19             Bio::Phylo::Treedrawer::Svg - Graphics format writer used by treedrawer, no
20             serviceable parts inside
21              
22             =head1 DESCRIPTION
23              
24             This module creates a scalable vector graphic from a Bio::Phylo::Forest::DrawTree
25             object. It is called by the L object, so look there to
26             learn how to create tree drawings.
27              
28             =begin comment
29              
30             Type : Constructor
31             Title : _new
32             Usage : my $svg = Bio::Phylo::Treedrawer::Svg->_new(%args);
33             Function: Initializes a Bio::Phylo::Treedrawer::Svg object.
34             Alias :
35             Returns : A Bio::Phylo::Treedrawer::Svg object.
36             Args : none.
37              
38             =end comment
39              
40             =cut
41              
42             sub _new {
43 2     2   5 my $class = shift;
44 2         9 my %opt = looks_like_hash @_;
45             my $self = $class->SUPER::_new(
46             %opt,
47             '-api' => SVG->new(
48             'width' => $opt{'-drawer'}->get_width,
49 2         11 'height' => $opt{'-drawer'}->get_height
50             )
51             );
52 2         33 $self->_api->tag( 'style', type => 'text/css' )
53             ->CDATA( "\n\tpolyline { fill: none; stroke: black; stroke-width: 1 }\n"
54             . "\tpath { fill: none; stroke: black; stroke-width: 1 }\n"
55             . "\tline { fill: none; stroke: black; stroke-width: 1 }\n"
56             . "\tcircle.node_circle {}\n"
57             . "\tcircle.taxon_circle {}\n"
58             . "\ttext.node_text {}\n"
59             . "\ttext.taxon_text {}\n"
60             . "\tline.scale_bar {}\n"
61             . "\ttext.scale_label {}\n"
62             . "\tline.scale_major {}\n"
63             . "\tline.scale_minor {}\n" );
64 2         113 return bless $self, $class;
65             }
66              
67             sub _finish {
68 2     2   4 my $self = shift;
69 2         5 undef %colors;
70 2         8 return $self->_api->render;
71             }
72              
73             =begin comment
74              
75             # required:
76             # -x1 => $x1,
77             # -y1 => $y1,
78             # -x2 => $x2,
79             # -y2 => $y2,
80             # -x3 => $x3,
81             # -y3 => $y3,
82              
83             # optional:
84             # -fill => $fill,
85             # -stroke => $stroke,
86             # -width => $width,
87             # -url => $url,
88             # -api => $api,
89              
90             =end comment
91              
92             =cut
93              
94             sub _draw_triangle {
95 0     0   0 my $self = shift;
96 0         0 my %args = @_;
97 0         0 my @coord = qw(-x1 -y1 -x2 -y2 -x3 -y3);
98 0         0 my ( $x1, $y1, $x2, $y2, $x3, $y3 ) = @args{@coord};
99 0         0 my @optional = qw(-fill -stroke -width -url -api);
100 0   0     0 my $fill = $args{'-fill'} || 'white';
101 0   0     0 my $stroke = $args{'-stroke'} || 'black';
102 0   0     0 my $width = $args{'-width'} || 1;
103 0   0     0 my $api = $args{'-api'} || $self->_api;
104 0 0       0 $api = $api->tag( 'a', 'xlink:href' => $args{'-url'} ) if $args{'-url'};
105 0         0 my $points = $self->_api->get_path(
106             'x' => [ int $x1, int $x2, int $x3, int $x1 ],
107             'y' => [ int $y1, int $y2, int $y3, int $y1 ],
108             '-type' => 'polygon',
109             );
110 0         0 delete @args{@coord};
111 0         0 delete @args{@optional};
112 0         0 return $api->polygon(
113             %$points,
114             'style' => {
115             'fill' => $fill,
116             'stroke' => $stroke,
117             'stroke-width' => $width,
118             },
119             %args
120             );
121             }
122              
123             =begin comment
124              
125             # required:
126             # -x => $x,
127             # -y => $y,
128             # -width => $width,
129             # -height => $height,
130              
131             # optional:
132             # -fill => $fill,
133             # -stroke => $stroke,
134             # -stroke_width => $stroke_width,
135             # -api => $api,
136              
137             =end comment
138              
139             =cut
140              
141             sub _draw_rectangle {
142 0     0   0 my $self = shift;
143 0         0 my %args = @_;
144 0         0 my @coord = qw(-x -y -width -height);
145 0         0 my ( $x, $y, $width, $height ) = @args{@coord};
146 0         0 my @optional = qw(-fill -stroke -stroke_width -api);
147 0   0     0 my $fill = $args{'-fill'} || 'white';
148 0   0     0 my $stroke = $args{'-stroke'} || 'black';
149 0   0     0 my $s_width = $args{'-stroke_width'} || 1;
150 0   0     0 my $api = $args{'-api'} || $self->_api;
151 0         0 delete @args{@coord};
152 0         0 delete @args{@optional};
153 0         0 return $api->rectangle(
154             'x' => $x,
155             'y' => $y,
156             'width' => $width,
157             'height' => $height,
158             'style' => {
159             'fill' => $fill,
160             'stroke' => $stroke,
161             'stroke-width' => $s_width,
162             },
163             );
164             }
165              
166             =begin comment
167              
168             # required:
169             # -x => $x,
170             # -y => $y,
171             # -text => $text,
172             #
173             # optional:
174             # -api => $api,
175             # -url => $url,
176             # -rotation => [ $rotation, $x, $y ]
177              
178             =end comment
179              
180             =cut
181              
182             sub _draw_text {
183 34     34   51 my $self = shift;
184 34         118 my %args = @_;
185 34         79 my ( $x, $y, $text ) = @args{qw(-x -y -text)};
186 34         43 my $url = $args{'-url'};
187 34   100     99 my $rotation = $args{'-rotation'} || [];
188 34   33     100 my $api = $args{'-api'} || $self->_api;
189 34         90 delete @args{qw(-x -y -text -api -url -rotation)};
190 34 50       63 if ( $url ) {
191 0         0 $api = $api->tag( 'a', 'xlink:href' => $url );
192             }
193 34         45 my @style;
194 34 50       52 if ( my $face = $args{'-font_face'} ) {
195 0         0 push @style, "font-family: ${face}";
196             }
197 34 50       63 if ( my $size = $args{'-font_size'} ) {
198 0         0 push @style, "font-size: ${size}"
199             }
200 34 50       58 if ( my $style = $args{'-font_style'} ) {
201 0         0 push @style, "font-style: ${style}";
202             }
203 34 50       53 if ( my $colour = $args{'-font_colour'} ) {
204 0         0 push @style, "fill: ${colour}";
205             }
206 34 50       62 if ( my $weight = $args{'-font_weight'} ) {
207 0         0 push @style, "font-weight: ${weight}";
208             }
209 2     2   13 no warnings 'uninitialized';
  2         6  
  2         2057  
210 34         219 return $api->tag(
211             'text',
212             'x' => $x,
213             'y' => $y,
214             'style' => join('; ',@style),
215             'transform' => "rotate(@${rotation})",
216             %args
217             )->cdata($text);
218             }
219              
220             =begin comment
221              
222             # -x => $x,
223             # -y => $y,
224             # -width => $width,
225             # -stroke => $color,
226             # -radius => $radius,
227             # -fill => $file,
228             # -api => $api,
229             # -url => $url,
230              
231             =end comment
232              
233             =cut
234              
235             sub _draw_circle {
236 10     10   15 my $self = shift;
237 10         42 my %args = @_;
238             my ( $x, $y, $radius, $width, $stroke, $fill, $api, $url ) =
239 10         38 @args{qw(-x -y -radius -width -stroke -fill -api -url)};
240 10 50       37 if ($radius) {
241 0   0     0 my $svg = $api || $self->_api;
242 0 0       0 if ($url) {
243 0         0 $svg = $svg->tag( 'a', 'xlink:href' => $url );
244             }
245 0   0     0 my %circle = (
      0        
      0        
246             'cx' => int $x,
247             'cy' => int $y,
248             'r' => int $radius,
249             'style' => {
250             'fill' => $fill || 'white',
251             'stroke' => $stroke || 'black',
252             'stroke-width' => $width || 1,
253             },
254             );
255 0         0 return $svg->tag( 'circle', %circle );
256             }
257             }
258              
259             =begin comment
260              
261             # -x1 => $x1,
262             # -x2 => $x2,
263             # -y1 => $y1,
264             # -y2 => $y2,
265             # -width => $width,
266             # -color => $color
267              
268             =end comment
269              
270             =cut
271              
272             sub _draw_curve {
273 8     8   15 my $self = shift;
274 8         33 my %args = @_;
275 8         25 my @keys = qw(-x1 -y1 -x2 -y2 -width -color);
276 8         30 my ( $x1, $y1, $x2, $y2, $width, $color ) = @args{@keys};
277 8         24 delete @args{@keys};
278 8         35 my $points = qq{M$x1,$y1 C$x1,$y2 $x2,$y2 $x2,$y2};
279 8   50     29 return $self->_api->path(
      50        
280             'd' => $points,
281             'style' => {
282             'stroke' => $color || 'black',
283             'stroke-width' => $width || 1,
284             }
285             );
286             }
287              
288             =begin comment
289              
290             # -x1 => $x1,
291             # -x2 => $x2,
292             # -y1 => $y1,
293             # -y2 => $y2,
294             # -radius => $radius
295             # -width => $width,
296             # -color => $color,
297             # -large => $large,
298             # -sweep => $sweep
299              
300             =end comment
301              
302             =cut
303              
304             sub _draw_arc {
305 0     0   0 my $self = shift;
306            
307             # process method arguments
308 0         0 my %args = @_;
309 0         0 my @keys = qw(-x1 -y1 -x2 -y2 -radius -width -color -linecap);
310 0         0 my ($x1, $y1, $x2, $y2, $radius, $width, $stroke, $linecap) = @args{@keys};
311 0 0       0 my $large = defined $args{'-large'} ? $args{'-large'} : 0; # default 0
312 0 0       0 my $sweep = defined $args{'-sweep'} ? $args{'-sweep'} : 1; # default 1
313            
314             # M = "moveto", i.e. the starting coordinates
315             # A = "elliptical Arc", The size and orientation of the ellipse are
316             # defined by two radii ($radius,$radius) and an x-axis-rotation
317             # (0.000), which indicates how the ellipse as a whole is rotated
318             # relative to the current coordinate system. The center of the
319             # ellipse is calculated automatically to satisfy the constraints
320             # imposed by the other parameters. large_arc_flag (0) and
321             # sweep-flag (1) contribute to the automatic calculations and
322             # help determine how the arc is drawn
323 0   0     0 $self->_api->path(
      0        
      0        
324            
325             # https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths#Arcs
326             'd' => "M $x1 $y1 A $radius $radius, 0, $large, $sweep, $x2 $y2",
327             'style' => {
328             'fill' => 'none',
329             'stroke' => $stroke || 'black',
330             'stroke-width' => $width || 1,
331             'stroke-linecap' => $linecap || 'butt',
332             },
333             );
334             }
335              
336             =begin comment
337              
338             # -x1 => $x1,
339             # -x2 => $x2,
340             # -y1 => $y1,
341             # -y2 => $y2,
342             # -width => $width,
343             # -color => $color
344              
345             =end comment
346              
347             =cut
348              
349             sub _draw_multi {
350 0     0   0 my $self = shift;
351 0         0 my %args = @_;
352 0         0 my @keys = qw(-x1 -y1 -x2 -y2 -width -color);
353 0         0 my ( $x1, $y1, $x2, $y2, $width, $color ) = @args{@keys};
354 0         0 delete @args{@keys};
355 0         0 my $points = qq{$x1,$y1 $x1,$y2 $x2,$y2};
356 0   0     0 return $self->_api->polyline(
      0        
357             'points' => $points,
358             'style' => {
359             'stroke' => $color || 'black',
360             'stroke-width' => $width || 1,
361             },
362             %args,
363             );
364             }
365              
366             =begin comment
367              
368             # -x1 => $x1,
369             # -x2 => $x2,
370             # -y1 => $y1,
371             # -y2 => $y2,
372             # -width => $width,
373             # -color => $color
374              
375             =end comment
376              
377             =cut
378              
379             sub _draw_line {
380 126     126   145 my $self = shift;
381 126         312 my %args = @_;
382 126         236 my @keys = qw( -x1 -y1 -x2 -y2 -width -color -linecap );
383 126         244 my ( $x1, $y1, $x2, $y2, $width, $color, $linecap ) = @args{@keys};
384 126         263 delete @args{@keys};
385 126   50     255 return $self->_api->line(
      50        
      50        
386             'x1' => $x1,
387             'y1' => $y1,
388             'x2' => $x2,
389             'y2' => $y2,
390             'style' => {
391             'stroke' => $color || 'black',
392             'stroke-width' => $width || 1,
393             'stroke-linecap' => $linecap || 'butt',
394             },
395             %args
396             );
397             }
398              
399             =begin comment
400              
401             Type : Internal method.
402             Title : _draw_pies
403             Usage : $svg->_draw_pies();
404             Function: Draws likelihood pies
405             Returns :
406             Args : None.
407             Comments: Code cribbed from SVG::PieGraph
408              
409             =end comment
410              
411             =cut
412              
413             sub _draw_pies {
414 2     2   7 my $self = shift;
415            
416             # normally, the colors for the likelihood pie are generated on the fly, but if
417             # set_pie_colors has been set in the superclass then we use those instead
418 2         4 my %c = %{ $self->_drawer->get_pie_colors };
  2         8  
419 2 50       10 %colors = %c if scalar keys %c;
420            
421             $self->_tree->visit_level_order(
422             sub {
423 10     10   18 my $node = shift;
424 10 50       45 if ( not $node->get_collapsed ) {
425 10         41 my $cx = int $node->get_x;
426 10         43 my $cy = int $node->get_y;
427 10         15 my $r;
428 10 100       35 if ( $node->is_internal ) {
429 4         11 $r = int $self->_drawer->get_node_radius($node);
430             }
431             else {
432 6         15 $r = int $self->_drawer->get_tip_radius($node);
433             }
434 10 50       51 if ( my $pievalues = $node->get_generic('pie') ) {
435 0         0 my @keys = keys %{$pievalues};
  0         0  
436 0         0 my $start = -90;
437 0         0 my $total;
438 0         0 $total += $pievalues->{$_} for @keys;
439 0         0 my $pie = $self->_api->tag(
440             'g',
441             'id' => 'pie_' . $node->get_id,
442             'transform' => "translate($cx,$cy)",
443             );
444 0         0 for my $i ( 0 .. $#keys ) {
445 0 0       0 next if not $pievalues->{ $keys[$i] };
446 0         0 my $slice = $pievalues->{ $keys[$i] } / $total * 360;
447 0         0 my $color = $colors{ $keys[$i] };
448 0 0       0 if ( not $color ) {
449 0         0 my $gray = int( ( $i / $#keys ) * 256 );
450 0         0 $colors{ $keys[$i] } = "rgb($gray,$gray,$gray)";
451             }
452 0         0 my $do_arc = 0;
453 0         0 my $radians = $slice * $PI / 180;
454 0 0       0 $do_arc++ if $slice > 180;
455 0         0 my $radius = $r - 2;
456 0         0 my $ry = $radius * sin($radians);
457 0         0 my $rx = $radius * cos($radians);
458 0         0 my $g =
459             $pie->tag( 'g', 'transform' => "rotate($start)" );
460 0         0 $g->path(
461             'style' =>
462             { 'fill' => "$color", 'stroke' => 'none' },
463             'd' =>
464             "M $radius,0 A $radius,$radius 0 $do_arc,1 $rx,$ry L 0,0 z"
465             );
466 0         0 $start += $slice;
467             }
468             }
469             }
470             }
471 2         8 );
472             }
473              
474             =begin comment
475              
476             Type : Internal method.
477             Title : _draw_legend
478             Usage : $svg->_draw_legend();
479             Function: Draws likelihood pie legend
480             Returns :
481             Args : None
482              
483             =end comment
484              
485             =cut
486              
487             sub _draw_legend {
488 2     2   6 my $self = shift;
489 2 50       7 if (%colors) {
490 0           my $svg = $self->_api;
491 0           my $tree = $self->_tree;
492 0           my $draw = $self->_drawer;
493 0           my @keys = keys %colors;
494 0           my $increment =
495             ( $tree->get_tallest_tip->get_x - $tree->get_root->get_x ) /
496             scalar @keys;
497 0           my $x = $tree->get_root->get_x + 5;
498 0           foreach my $key (@keys) {
499             $svg->rectangle(
500             'x' => $x,
501             'y' => ( $draw->get_height - 90 ),
502             'width' => ( $increment - 10 ),
503             'height' => 10,
504             'id' => 'legend_' . $key,
505             'style' => {
506 0           'fill' => $colors{$key},
507             'stroke' => 'black',
508             'stroke-width' => '1',
509             },
510             );
511 0   0       $self->_draw_text(
512             '-x' => $x,
513             '-y' => ( $draw->get_height - 60 ),
514             '-text' => $key || ' ',
515             'class' => 'legend_label'
516             );
517 0           $x += $increment;
518             }
519             $self->_draw_text(
520 0           '-x' =>
521             ( $tree->get_tallest_tip->get_x + $draw->get_text_horiz_offset ),
522             '-y' => ( $draw->get_height - 80 ),
523             '-text' => 'Node value legend',
524             'class' => 'legend_text',
525             );
526             }
527             }
528              
529             =head1 SEE ALSO
530              
531             There is a mailing list at L
532             for any user or developer questions and discussions.
533              
534             =over
535              
536             =item L
537              
538             The svg treedrawer is called by the L object. Look there
539             to learn how to create tree drawings.
540              
541             =item L
542              
543             Also see the manual: L and L.
544              
545             =back
546              
547             =head1 CITATION
548              
549             If you use Bio::Phylo in published research, please cite it:
550              
551             B, B, B, B
552             and B, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
553             I B<12>:63.
554             L
555              
556             =cut
557              
558             1;