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

package Text::Graph;

use strict;
use warnings;
use Moo;
use namespace::clean;

use Text::Graph::DataSet;

our $VERSION = '0.83';

has style => (
    is     => 'ro',
    reader => '_style',
);
# Data Display properties
has marker => (
    is     => 'ro',
    reader => 'get_marker',
);
has fill => (
    is     => 'ro',
    reader => 'get_fill',
);
has log => (
    is     => 'ro',
    reader => 'is_log',
);
# Data Limit Properties
has maxval => (
    is     => 'ro',
    reader => 'get_maxval',
);
has minval => (
    is     => 'ro',
    reader => 'get_minval',
);
has maxlen => (
    is     => 'ro',
    reader => 'get_maxlen',
);
# Graph Display Options
has separator => (
    is     => 'ro',
    reader => 'get_separator',
);
has right => (
    is     => 'ro',
    reader => 'is_right_justified',
);
has showval => (
    is     => 'ro',
    reader => 'show_value',
);

sub BUILDARGS
{
    my ( $class, @args ) = @_;
    my $style = shift( @args ) || 'Bar';

    my $obj = {
        _initialize( $style ),

        # data display
        log => 0,

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

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

    return $obj;
}

#--------------------------------------------
#  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";
    }
}

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__