File Coverage

blib/lib/Text/BoxPlot.pm

Criterion	Covered	Total	%
statement	64	65	98.4
branch	6	8	75.0
condition	2	4	50.0
subroutine	10	10	100.0
pod	1	1	100.0
total	83	88	94.3

use 5.008001;
use strict;
use warnings;

package Text::BoxPlot;
# ABSTRACT: Render ASCII box and whisker charts
our $VERSION = '0.001'; # VERSION

use Moo;
use MooX::Types::MooseLike::Base qw/Bool/;
use MooX::Types::MooseLike::Numeric qw/PositiveNum/;
use List::AllUtils qw/min max/;

use constant {
    NAME => 0,
    MIN  => 1,
    Q1   => 2,
    MED  => 3,
    Q3   => 4,
    MAX  => 5,
};



has width => (
    is      => 'ro',
    isa     => PositiveNum,
    default => sub { 72 },
);


has label_width => (
    is      => 'ro',
    isa     => PositiveNum,
    default => sub { 10 },
);


has box_weight => (
    is      => 'ro',
    isa     => PositiveNum,
    default => sub { 1 },
);


has with_scale => (
    is  => 'ro',
    isa => Bool,
);


sub render {
    my ( $self, @datasets ) = @_;
    my $gamma = 2 * max( 0, $self->box_weight || 1 );
    my $adj_width = $self->width - $self->label_width - 2;

    my $smallest_min = min( map { $_->[MIN] } @datasets );
    my $smallest_q1  = min( map { $_->[Q1] } @datasets );
    my $biggest_q3   = max( map { $_->[Q3] } @datasets );
    my $biggest_max  = max( map { $_->[MAX] } @datasets );

    my $span = ( $biggest_q3 - $smallest_q1 ) || 1;
    my $factor = $adj_width * $gamma / ( 2 + $gamma ) / $span;

    my $origin = int( $factor * ( $smallest_q1 - $span / $gamma ) );
    my $edge   = int( $factor * ( $biggest_q3 + $span / $gamma ) );
##    warn "SPAN: $span; FACTOR: $factor;  ORIGIN: $origin; EDGE: $edge; AW: $adj_width (" . ($edge - $origin) . ")\n";

    my @str;
    if ( $self->with_scale ) {
        push @str,
          ( " " x ($self->label_width) )
          . sprintf( " |%-*g%*g|",
            $adj_width / 2,
            $origin / $factor,
            $adj_width / 2,
            $edge / $factor );
    }

    for my $d (@datasets) {
        my ( $name, @copy ) = @$d;
##        warn "PRECOPY: @copy\n";
        my @scaled = ( $name, map { int( $factor * $_ ) } @copy );
##        warn "POSTCOPY: @scaled\n";
        push @str, _render_one( \@scaled, $origin, $edge, $adj_width, $self->label_width );
    }

    return wantarray ? @str : $str[0];
}

sub _render_one {
    my ( $data, $origin, $edge, $frame_size, $label_width ) = @_;
##    warn "DATA: @$data\n";
    my $str = '';
    $str .= q{ } x ( max( $data->[MIN] - $origin, 0 ) );
    $str .= q{-} x ( $data->[Q1] - max( $data->[MIN], $origin ) );
    $str .= q{=} x ( $data->[MED] - $data->[Q1] );
    $str .= "O";
    $str .= q{=} x ( $data->[Q3] - $data->[MED] );
    $str .= q{-} x ( min( $data->[MAX], $edge ) - $data->[Q3] );
    $str .= q{ } x ( max( $edge - $data->[MAX], 0 ) );
##    warn "STR: " . length($str) . "\n";
    $str = substr( $str, 0, $frame_size );
##    $str =~ s{^(.{0,$frame_size})}{$1};
##    warn "STR: " . length($str) . "\n";

    if ( substr( $str, 0, 1 ) eq '-' ) {
        substr( $str, 0, 1, "<" );
    }

    if ( substr( $str, -1, 1 ) eq '-' ) {
        substr( $str, -1, 1, "->" );
    }

    $str =~ s{\s+$}{};
    my $name = substr($data->[NAME],0, $label_width);
    return sprintf( "%*s %s", $label_width, $name, $str );
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__