File Coverage

blib/lib/Text/Graph.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	44	44	100.0
condition	11	11	100.0
subroutine	23	23	100.0
pod	13	13	100.0
total	187	187	100.0

package Text::Graph;

use strict;
use warnings;
use Text::Graph::DataSet;

our $VERSION = '0.50';

sub new
{
    my $class = shift;
    my $style = shift || 'Bar';

    my $obj = {
        _initialize( $style ),

        # data display
        log => 0,

        # data limit
        maxval => undef,
        minval => undef,
        maxlen => undef,

        # graph display
        separator => ' :',
        right     => 0,
        showval   => 0,
        @_
    };
    $obj->{fill} = $obj->{marker} unless defined $obj->{fill};

    return bless $obj, $class;
}

#--------------------------------------------
#  INTERNAL: Initialize the default parameters based on the supplied
#  style.
sub _initialize
{
    my $style  = shift;
    my $lstyle = lc $style;

    if( 'bar' eq $lstyle )
    {
        return ( style => 'Bar', marker => '*' );
    }
    elsif( 'line' eq $lstyle )
    {
        return ( style => 'Line', marker => '*', fill => ' ' );
    }
    else
    {
        die "Unknown style '$style'.\n";
    }
}

# Data Display Options
sub get_marker { return $_[0]->{marker}; }
sub get_fill   { return $_[0]->{fill}; }
sub is_log     { return $_[0]->{log}; }

# Data Limit Options
sub get_maxlen { return $_[0]->{maxlen}; }
sub get_maxval { return $_[0]->{maxval}; }
sub get_minval { return $_[0]->{minval}; }

# Graph Display Options
sub get_separator      { return $_[0]->{separator}; }
sub is_right_justified { return $_[0]->{right}; }
sub show_value         { return $_[0]->{showval}; }

sub make_lines
{
    my $self = shift;
    my $data = _make_graph_data( @_ );

    my @lines = _histogram( $data, $self );

    return wantarray ? @lines : \@lines;
}

sub make_labelled_lines
{
    my $self = shift;
    my $data = _make_graph_data( @_ );

    my @labels = _fmt_labels( $self->{right}, $data->get_labels() );
    my @lines = $self->make_lines( $data );
    foreach my $i ( 0 .. $#lines )
    {
        $lines[$i] = $labels[$i] . $self->{separator} . $lines[$i];
    }

    return wantarray ? @lines : \@lines;
}

sub to_string
{
    my $self = shift;

    return join( "\n", $self->make_labelled_lines( @_ ) ) . "\n";
}

#--------------------------------------------
#  INTERNAL: Convert input parameters to a graph data object as needed.
sub _make_graph_data
{
    if( 'Text::Graph::DataSet' eq ref $_[0] )
    {
        return shift;
    }
    else
    {
        return Text::Graph::DataSet->new( @_ );
    }
}

#--------------------------------------------
#  INTERNAL: This routine pads the labels as needed.
sub _fmt_labels
{
    my $right = shift;
    my $len   = 0;
    my @labels;

    foreach my $label ( @_ )
    {
        $len = length $label if length $label > $len;
    }

    if( $right )
    {
        @labels = map { ( ' ' x ( $len - length $_ ) ) . $_ } @_;
    }
    else
    {
        my $pad = ' ' x $len;

        @labels = map { substr( ( $_ . $pad ), 0, $len ) } @_;
    }

    return @labels;
}

#--------------------------------------------
#  INTERNAL: This is the workhorse routine that actually builds the
#  histogram bars.
sub _histogram
{
    my ($dset, $args) = @_;
    my $parms = { %{$args}, labels => [ $dset->get_labels ] };
    my @values;

    $parms->{fill} ||= $parms->{marker};

    my @orig = $dset->get_values;
    if( $parms->{log} )
    {
        @values = map { log } @orig;

        $parms->{minval} = 1 if defined $parms->{minval} and !$parms->{minval};

        $parms->{minval} = log $parms->{minval} if $parms->{minval};
        $parms->{maxval} = log $parms->{maxval} if $parms->{maxval};
    }
    else
    {
        @values = @orig;
    }

    unless( defined( $parms->{minval} ) and defined( $parms->{maxval} ) )
    {
        my ( $min, $max ) = _minmax( \@values );
        $parms->{minval} = $min unless defined $parms->{minval};
        $parms->{maxval} = $max unless defined $parms->{maxval};
    }

    $parms->{maxlen} = $parms->{maxval} - $parms->{minval}
        unless defined $parms->{maxlen};
    my $scale = $parms->{maxlen} / ( $parms->{maxval} - $parms->{minval} );

    @values =
        map { _makebar( ( $_ - $parms->{minval} ) * $scale, $parms->{marker}, $parms->{fill} ) }
        map { _make_within( $_, $parms->{minval}, $parms->{maxval} ) } @values;

    if( $parms->{showval} )
    {
        foreach my $i ( 0 .. $#values )
        {
            $values[$i] .=
                ( ' ' x ( $parms->{maxlen} - length $values[$i] ) ) . '  (' . $orig[$i] . ')';
        }
    }

    return @values;
}

#--------------------------------------------
#  INTERNAL: This routine finds both the minimum and maximum of
#  an array of values.
sub _minmax
{
    my $list = shift;
    my ( $min, $max );

    $min = $max = $list->[0];

    foreach ( @{$list} )
    {
        if( $_ > $max )    { $max = $_; }
        elsif( $_ < $min ) { $min = $_; }
    }

    return ( $min, $max );
}

#--------------------------------------------
#  INTERNAL: This routine expects a number, a minimum, and a maximum.
#  It returns a number with the range.
sub _make_within
{
    return ( $_[0] < $_[1] ) ? $_[1] : ( $_[0] > $_[2] ? $_[2] : $_[0] );
}

#--------------------------------------------
#  INTERNAL: This routine builds the actual histogram bar.
sub _makebar
{
    my ( $val, $m, $f, $s ) = @_;

    $val = int( $val + 0.5 );

    return $val > 0 ? ( ( $f x ( $val - 1 ) ) . $m ) : '';
}

1;

__END__