File Coverage

blib/lib/Data/TableAutoSum.pm

Criterion	Covered	Total	%
statement	138	138	100.0
branch	16	16	100.0
condition	12	17	70.5
subroutine	31	31	100.0
pod	15	17	88.2
total	212	219	96.8

package Data::TableAutoSum;

use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# I export nothing, so there aren't any @EXPORT* declarations

our $VERSION = '0.11';

use Params::Validate qw/:all/;
use Regexp::Common;
use Set::Scalar;
use List::Util qw/reduce/;
use Tie::CSV_File;
use Data::Compare;

sub implies($$) {
    my ($x, $y) = @_;
    return !$x || ($x && $y);
}

sub is_uniq(@) {
    my %items;
    foreach (@_) {
        return 0 if $items{$_}++;
    }
    return 1;
}

use constant ROW_COL_TYPE => {
    type      => SCALAR | ARRAYREF,
    callbacks =>  {
        # scalar value
        'integer'          => sub { implies !ref($_[0]) => $_[0] =~ $RE{num}{int} },
            'greater than 0'   => sub { implies !ref($_[0]) => ($_[0] =~ $RE{num}{int}) && (int($_[0]) > 0) },

        # array ref
        'uniq identifiers' => sub { no strict 'refs';
                                    implies ref($_[0])  => is_uniq @{$_[0]} },
        'some identifiers' => sub { no strict 'refs';
                                    implies ref($_[0])  => @{$_[0]} }
    }
};

sub new {
    my $proto = shift;
    my %arg = validate( @_ => {rows => ROW_COL_TYPE, cols => ROW_COL_TYPE} );
    my $class = ref($proto) || $proto;
    my @rows = ref($arg{rows}) ? @{$arg{rows}} : (0 .. $arg{rows}-1);
    my @cols = ref($arg{cols}) ? @{$arg{cols}} : (0 .. $arg{cols}-1);
    my %data;
    foreach my $row (@rows) {
        foreach my $col (@cols) {
            $data{$row}->{$col} = 0;
        }
    }
    my $self = {
        rows   => \@rows,
        rowset => Set::Scalar->new(@rows),
        cols   => \@cols,
        colset => Set::Scalar->new(@cols),
        data   => \%data
    };
    bless $self, $class;
}

sub rows {
    my $self = shift;
    return @{$self->{rows}};
}

sub cols {
    my $self = shift;
    return @{$self->{cols}};
}

sub data : lvalue {
    my $self = shift;
    my ($row, $col, $value) = validate_pos( @_,
        {type => SCALAR,
         callbacks => {'is a row' => sub {$self->{rowset}->contains(shift())}}
        },
        {type => SCALAR,
         callbacks => {'is a col' => sub {$self->{colset}->contains(shift())}}
        },
        0
    );
    $self->{data}->{$row}->{$col} = $value if defined $value;
    $self->{data}->{$row}->{$col};
}

sub as_string {
    my $self = shift;
    my $output = join "\t", "", $self->cols, "Sum\n";
    foreach my $row ($self->rows) {
        $output .= $row . "\t";
        $output .= join "\t", map {$self->data($row,$_)} ($self->cols);
        $output .= "\t" . $self->rowresult($row) . "\n";
    }
    $output .= join "\t", "Sum", map {$self->colresult($_)} $self->cols;
    $output .= "\t" . $self->totalresult . "\n";
    return $output;
}

sub store {
    local $| = 1;
    my ($self, $filename) = @_;
    defined($filename) && (open FILE, ">$filename") or die "Can't open filename '" . ($filename // '') . "'  to store the table";
    print FILE $self->as_string;
    close FILE;
    return $self;
}

sub read {
    my ($class, $filename) = @_;
    defined($filename) or die "Can't open undefined fileman in Data::TableAutoSum->read";
    tie my @data, 'Tie::CSV_File', $filename, sep_char     => "\t",
                                              quote_char   => undef,
                                              escape_char  => undef;


    my @header       = @{ $data[0] };
    my @col = @header[1 .. $#header-1];
    my @row = map {$data[$_]->[0]} (1 .. $#data-1);
    my $table        = $class->new(rows => \@row, cols => \@col);

    foreach my $i (0 .. $#row) {
        foreach my $j (0 .. $#col) {
            $table->data($row[$i],$col[$j]) = $data[$i+1][$j+1];
        }
    }

    untie @data;
    return $table;
}

sub change {
    my ($self, $sub) = @_;
    foreach my $row ($self->rows) {
        foreach my $col ($self->cols) {
            local $_ = $self->data($row,$col);
            &$sub;
            $self->data($row,$col) = $_;
        }
    }
}

sub merge {
    my ($class, $sub, $table1, $table2) = @_;
    my @row = $table1->rows;
    my @col = $table1->cols;
    my $merged = $class->new(rows => \@row, cols => \@col);
    foreach my $i (@row) {
        foreach my $j (@col) {
            $merged->data($i,$j) = $sub->($table1->data($i,$j), $table2->data($i,$j));
        }
    }
    return $merged;
}

sub _calc_data {
    my $result = $_[0];
    $result += $_[$_] for (1 .. $#_);
    return $result;
}

sub rowresult {
    my ($self, $row) = @_;
    return _calc_data( map {$self->data($row,$_)} $self->cols );
}

sub colresult {
    my ($self, $col) = @_;
    return _calc_data( map {$self->data($_,$col)} $self->rows );
}

sub totalresult {
    my $self = shift;
    return _calc_data( map {values %$_} values %{$self->{data}} );
}

sub contains_row {
    my ($self, $row) = @_;
    $self->{rowset}->contains($row);
}

sub contains_col {
    my ($self, $col) = @_;
    $self->{colset}->contains($col);
}

sub is_equal {
    my ($self, $other) = @_;
    Compare( [$self->rows], [$other->rows] ) &&
    Compare( [$self->cols], [$other->cols] ) or return 0;
    foreach my $row ($self->rows) {
        foreach my $col ($self->cols) {
            $self->data($row,$col) == $other->data($row,$col) or return 0;
        }
    }
    1;
}

1;
__END__