File Coverage

blib/lib/Text/Graph.pm
Criterion Covered Total %
statement 93 93 100.0
branch 44 44 100.0
condition 11 11 100.0
subroutine 16 16 100.0
pod 3 4 75.0
total 167 168 99.4


line stmt bran cond sub pod time code
1             package Text::Graph;
2              
3 7     7   126335 use strict;
  7         15  
  7         225  
4 7     7   28 use warnings;
  7         8  
  7         147  
5 7     7   329232 use Moo;
  7         79058  
  7         33  
6 7     7   12448 use namespace::clean;
  7         965049  
  7         38  
7              
8 7     7   3702 use Text::Graph::DataSet;
  7         19  
  7         7080  
9              
10             our $VERSION = '0.83';
11              
12             has style => (
13             is => 'ro',
14             reader => '_style',
15             );
16             # Data Display properties
17             has marker => (
18             is => 'ro',
19             reader => 'get_marker',
20             );
21             has fill => (
22             is => 'ro',
23             reader => 'get_fill',
24             );
25             has log => (
26             is => 'ro',
27             reader => 'is_log',
28             );
29             # Data Limit Properties
30             has maxval => (
31             is => 'ro',
32             reader => 'get_maxval',
33             );
34             has minval => (
35             is => 'ro',
36             reader => 'get_minval',
37             );
38             has maxlen => (
39             is => 'ro',
40             reader => 'get_maxlen',
41             );
42             # Graph Display Options
43             has separator => (
44             is => 'ro',
45             reader => 'get_separator',
46             );
47             has right => (
48             is => 'ro',
49             reader => 'is_right_justified',
50             );
51             has showval => (
52             is => 'ro',
53             reader => 'show_value',
54             );
55              
56             sub BUILDARGS
57             {
58 45     45 0 28929 my ( $class, @args ) = @_;
59 45   100     119 my $style = shift( @args ) || 'Bar';
60              
61 45         83 my $obj = {
62             _initialize( $style ),
63              
64             # data display
65             log => 0,
66              
67             # data limit
68             maxval => undef,
69             minval => undef,
70             maxlen => undef,
71              
72             # graph display
73             separator => ' :',
74             right => 0,
75             showval => 0,
76             @args
77             };
78 44 100       117 $obj->{fill} = $obj->{marker} unless defined $obj->{fill};
79              
80 44         712 return $obj;
81             }
82              
83             #--------------------------------------------
84             # INTERNAL: Initialize the default parameters based on the supplied
85             # style.
86             sub _initialize
87             {
88 45     45   38 my $style = shift;
89 45         69 my $lstyle = lc $style;
90              
91 45 100       106 if( 'bar' eq $lstyle )
    100          
92             {
93 26         152 return ( style => 'Bar', marker => '*' );
94             }
95             elsif( 'line' eq $lstyle )
96             {
97 18         123 return ( style => 'Line', marker => '*', fill => ' ' );
98             }
99             else
100             {
101 1         7 die "Unknown style '$style'.\n";
102             }
103             }
104              
105             sub make_lines
106             {
107 43     43 1 82 my $self = shift;
108 43         63 my $data = _make_graph_data( @_ );
109              
110 43         66 my @lines = _histogram( $data, $self );
111              
112 43 100       164 return wantarray ? @lines : \@lines;
113             }
114              
115             sub make_labelled_lines
116             {
117 41     41 1 139 my $self = shift;
118 41         65 my $data = _make_graph_data( @_ );
119              
120 41         870 my @labels = _fmt_labels( $self->{right}, $data->get_labels() );
121 41         89 my @lines = $self->make_lines( $data );
122 41         83 foreach my $i ( 0 .. $#lines )
123             {
124 287         460 $lines[$i] = $labels[$i] . $self->{separator} . $lines[$i];
125             }
126              
127 41 100       299 return wantarray ? @lines : \@lines;
128             }
129              
130             sub to_string
131             {
132 35     35 1 3890 my $self = shift;
133              
134 35         62 return join( "\n", $self->make_labelled_lines( @_ ) ) . "\n";
135             }
136              
137             #--------------------------------------------
138             # INTERNAL: Convert input parameters to a graph data object as needed.
139             sub _make_graph_data
140             {
141 84 100   84   159 if( 'Text::Graph::DataSet' eq ref $_[0] )
142             {
143 79         100 return shift;
144             }
145             else
146             {
147 5         86 return Text::Graph::DataSet->new( @_ );
148             }
149             }
150              
151             #--------------------------------------------
152             # INTERNAL: This routine pads the labels as needed.
153             sub _fmt_labels
154             {
155 41     41   43 my $right = shift;
156 41         43 my $len = 0;
157 41         28 my @labels;
158              
159 41         65 foreach my $label ( @_ )
160             {
161 287 100       438 $len = length $label if length $label > $len;
162             }
163              
164 41 100       70 if( $right )
165             {
166 2         5 @labels = map { ( ' ' x ( $len - length $_ ) ) . $_ } @_;
  14         25  
167             }
168             else
169             {
170 39         59 my $pad = ' ' x $len;
171              
172 39         44 @labels = map { substr( ( $_ . $pad ), 0, $len ) } @_;
  273         435  
173             }
174              
175 41         122 return @labels;
176             }
177              
178             #--------------------------------------------
179             # INTERNAL: This is the workhorse routine that actually builds the
180             # histogram bars.
181             sub _histogram
182             {
183 43     43   40 my ( $dset, $args ) = @_;
184 43         37 my $parms = { %{$args}, labels => [ $dset->get_labels ] };
  43         942  
185 43         69 my @values;
186              
187 43   100     92 $parms->{fill} ||= $parms->{marker};
188              
189 43         783 my @orig = $dset->get_values;
190 43 100       79 if( $parms->{log} )
191             {
192 10         17 @values = map { log } @orig;
  70         99  
193              
194 10 100 100     49 $parms->{minval} = 1 if defined $parms->{minval} and !$parms->{minval};
195              
196 10 100       41 $parms->{minval} = log $parms->{minval} if $parms->{minval};
197 10 100       22 $parms->{maxval} = log $parms->{maxval} if $parms->{maxval};
198             }
199             else
200             {
201 33         51 @values = @orig;
202             }
203              
204 43 100 100     127 unless( defined( $parms->{minval} ) and defined( $parms->{maxval} ) )
205             {
206 37         74 my ( $min, $max ) = _minmax( \@values );
207 37 100       77 $parms->{minval} = $min unless defined $parms->{minval};
208 37 100       65 $parms->{maxval} = $max unless defined $parms->{maxval};
209             }
210              
211 43 100       95 $parms->{maxlen} = $parms->{maxval} - $parms->{minval}
212             unless defined $parms->{maxlen};
213 43         81 my $scale = $parms->{maxlen} / ( $parms->{maxval} - $parms->{minval} );
214              
215 301         483 @values =
216 301         351 map { _makebar( ( $_ - $parms->{minval} ) * $scale, $parms->{marker}, $parms->{fill} ) }
217 43         53 map { _make_within( $_, $parms->{minval}, $parms->{maxval} ) } @values;
218              
219 43 100       117 if( $parms->{showval} )
220             {
221 4         10 foreach my $i ( 0 .. $#values )
222             {
223 28         62 $values[$i] .=
224             ( ' ' x ( $parms->{maxlen} - length $values[$i] ) ) . ' (' . $orig[$i] . ')';
225             }
226             }
227              
228 43         248 return @values;
229             }
230              
231             #--------------------------------------------
232             # INTERNAL: This routine finds both the minimum and maximum of
233             # an array of values.
234             sub _minmax
235             {
236 37     37   38 my $list = shift;
237 37         29 my ( $min, $max );
238              
239 37         44 $min = $max = $list->[0];
240              
241 37         29 foreach ( @{$list} )
  37         55  
242             {
243 259 100       413 if( $_ > $max ) { $max = $_; }
  144 100       112  
244 16         20 elsif( $_ < $min ) { $min = $_; }
245             }
246              
247 37         64 return ( $min, $max );
248             }
249              
250             #--------------------------------------------
251             # INTERNAL: This routine expects a number, a minimum, and a maximum.
252             # It returns a number with the range.
253             sub _make_within
254             {
255 301 100   301   602 return ( $_[0] < $_[1] ) ? $_[1] : ( $_[0] > $_[2] ? $_[2] : $_[0] );
    100          
256             }
257              
258             #--------------------------------------------
259             # INTERNAL: This routine builds the actual histogram bar.
260             sub _makebar
261             {
262 301     301   286 my ( $val, $m, $f, $s ) = @_;
263              
264 301         262 $val = int( $val + 0.5 );
265              
266 301 100       773 return $val > 0 ? ( ( $f x ( $val - 1 ) ) . $m ) : '';
267             }
268              
269             1;
270              
271             __END__