File Coverage

blib/lib/Data/Freq/Field.pm

Criterion	Covered	Total	%
statement	188	192	97.9
branch	115	134	85.8
condition	32	46	69.5
subroutine	26	26	100.0
pod	13	13	100.0
total	374	411	91.0

use 5.006;
use strict;
use warnings;

package Data::Freq::Field;

=head1 NAME

Data::Freq::Field - Controls counting with Data::Freq at each level

=cut

use Carp qw(croak);
use Date::Parse qw(str2time);
use Scalar::Util qw(looks_like_number);
require POSIX;

=head1 METHODS

=head2 new

Usage:

    Data::Freq::Field->new({
        type    => 'text' , # { 'text' | 'number' | 'date' }
        sort    => 'count', # { 'value' | 'count' | 'first' | 'last' }
        order   => 'desc' , # { 'asc' | 'desc' }
        pos     => 0      , # { 0 | 1 | 2 | -1 | -2 | .. | [0, 1, 2] | .. }
        key     => 'mykey', # { any key(s) for input hash refs }
        convert => sub {...},
    });

Constructs a field object.

See L for details.

=cut

sub new {
    my ($class, $input) = @_;
    my $self = bless {}, $class;

    if (!ref $input) {
        $self->_extract_any($input) or croak "invalid argument: $input";
    } elsif (ref $input eq 'HASH') {
        for my $target (qw(type aggregate sort order pos key)) {
            if (defined $input->{$target}) {
                my $method = "_extract_$target";

                $self->$method($input->{$target})
                        or croak "invalid $target: $input->{$target}";
            }
        }

        for my $target (qw(offset limit)) {
            if (defined $input->{$target}) {
                $self->{$target} = int($input->{$target});
            }
        }

        for my $target (qw(convert)) {
            if (defined $input->{$target}) {
                $self->{$target} = $input->{$target};

                if (ref $input->{$target} ne 'CODE') {
                    croak "$target must be a CODE ref";
                }
            }
        }
    } elsif (ref $input eq 'ARRAY') {
        for my $item (@$input) {
            $self->_extract_any($item) or croak "invalid argument: $item";
        }
    } else {
        croak "invalid field: $input";
    }

    $self->{type} = 'text' unless defined $self->type;
    $self->{aggregate} ||= 'count';

    if ($self->type eq 'text') {
        $self->{sort} ||= 'score';
    } else {
        $self->{sort} ||= 'value';
    }

    if ($self->{sort} =~ /^(count|score|last)$/) {
        $self->{order} ||= 'desc';
    } else {
        $self->{order} ||= 'asc';
    }

    return $self;
}

=head2 evaluate_record

Usage:

    my $field = Data::Freq::Field->new(...);
    my $record = Data::Freq::Record->new(...);
    my $normalized_text = $field->evaluate_record($record);

Evaluates an input record as a normalized text that will be used for frequency counting,
depending on the parameters passed to the L method.

This is intended to be an internal method for L.

=cut

sub evaluate_record {
    my ($self, $record) = @_;
    my $result = undef;

    TRY: {
        if (defined $self->pos) {
            my $pos = $self->pos;
            my $array = $record->array or last TRY;
            $result = "@$array[@$pos]";
        } elsif (defined $self->key) {
            my $key = $self->key;
            my $hash = $record->hash or last TRY;
            $result = "@$hash{@$key}";
        } elsif ($self->type eq 'date') {
            $result = $record->date;
        } elsif ($self->type eq 'number') {
            my $array = $record->array or last TRY;
            $result = $array->[0];
        } else {
            $result = $record->text;
        }

        last TRY unless defined $result;

        if ($self->type eq 'date') {
            $result = looks_like_number($result) ? $result : str2time($result);
            last TRY unless defined $result;
            $result = POSIX::strftime($self->strftime, localtime $result);
        }
    }

    if ($self->convert) {
        $result = $self->convert->($result);
    }

    return $result;
}

=head2 select_nodes

Usage:

    my $raw_node_list = [values %{$parent_node->children}];
    my $sorted_node_list = $field->select_nodes($raw_node_list);

Sorts and reduces a list of nodes (Data::Freq::Node) at the corresponding depth
in the L,
depending on the parameters passed to the L method.

This is intended to be an internal method for L.

=cut

sub select_nodes {
    my ($self, $nodes, $subfield) = @_;
    my $type  = $self->type;
    my $sort  = $self->sort;
    my $order = $self->order;

    if ($sort eq 'score') {
        if ($subfield) {
            $sort = $subfield->aggregate;
        } else {
            $sort = 'count';
        }
    }

    my @tuples = map {[$_, $_->$sort, $_->first]} @$nodes;

    if ($type ne 'number' && $sort eq 'value') {
        if ($order eq 'asc') {
            @tuples = CORE::sort {$a->[1] cmp $b->[1] || $a->[2] <=> $b->[2]} @tuples;
        } else {
            @tuples = CORE::sort {$b->[1] cmp $a->[1] || $a->[2] <=> $b->[2]} @tuples;
        }
    } else {
        if ($order eq 'asc') {
            @tuples = CORE::sort {$a->[1] <=> $b->[1] || $a->[2] <=> $b->[2]} @tuples;
        } else {
            @tuples = CORE::sort {$b->[1] <=> $a->[1] || $a->[2] <=> $b->[2]} @tuples;
        }
    }

    my @result = map {$_->[0]} @tuples;

    if (defined $self->offset || defined $self->limit) {
        my $offset = defined $self->offset ? $self->offset : 0;
        my $length = defined $self->limit ? $self->limit : scalar(@result);
        @result = splice(@result, $offset, $length);
    }

    return \@result;
}

=head2 type

Retrieves the C parameter.

=head2 aggregate

Retrieves the C parameter.

=head2 sort

Retrieves the C parameter.

=head2 order

Retrieves the C parameter.

=head2 pos

Retrieves the C parameter as an array ref.

=head2 key

Retrieves the C parameter as an array ref.

=head2 limit

Retrieves the C parameter.

=head2 offset

Retrieves the C parameter.

=head2 strftime

Retrieves the C parameter (L).

=head2 convert

Retrieves the C parameter.

=cut

sub type      {$_[0]{type    }}
sub aggregate {$_[0]{aggregate}}
sub sort      {$_[0]{sort    }}
sub order     {$_[0]{order   }}
sub pos       {$_[0]{pos     }}
sub key       {$_[0]{key     }}
sub limit     {$_[0]{limit   }}
sub offset    {$_[0]{offset  }}
sub strftime  {$_[0]{strftime}}
sub convert   {$_[0]{convert }}

sub _extract_any {
    my ($self, $input) = @_;

    for my $target (qw(pos type aggregate sort order)) {
        my $method = "_extract_$target";
        return $self if $self->$method($input);
    }

    return undef;
}

sub _extract_type {
    my ($self, $input) = @_;
    return undef if ref($input);

    if (!defined $input || $input eq '' || $input =~ /^texts?$/i) {
        $self->{type} = 'text';
        return $self;
    } elsif ($input =~ /^num(ber)?s?$/i) {
        $self->{type} = 'number';
        return $self;
    } elsif ($input =~ /\%/) {
        $self->{type} = 'date';
        $self->{strftime} = $input;
        return $self;
    } elsif ($input =~ /^years?$/i) {
        $self->{type} = 'date';
        $self->{strftime} = '%Y';
        return $self;
    } elsif ($input =~ /^month?s?$/i) {
        $self->{type} = 'date';
        $self->{strftime} = '%Y-%m';
        return $self;
    } elsif ($input =~ /^(date|day)s?$/i) {
        $self->{type} = 'date';
        $self->{strftime} = '%Y-%m-%d';
        return $self;
    } elsif ($input =~ /^hours?$/i) {
        $self->{type} = 'date';
        $self->{strftime} = '%Y-%m-%d %H';
        return $self;
    } elsif ($input =~ /^minutes?$/i) {
        $self->{type} = 'date';
        $self->{strftime} = '%Y-%m-%d %H:%M';
        return $self;
    } elsif ($input =~ /^(seconds?|time)?$/i) {
        $self->{type} = 'date';
        $self->{strftime} = '%Y-%m-%d %H:%M:%S';
        return $self;
    }

    return undef;
}

sub _extract_aggregate {
    my ($self, $input) = @_;
    return undef if !defined $input || ref($input) || $input eq '';

    if ($input =~ /^uniq(ue)?$/) {
        $self->{aggregate} = 'unique';
        return $self;
    } elsif ($input =~ /^max(imum)?$/) {
        $self->{aggregate} = 'max';
        return $self;
    } elsif ($input =~ /^min(imum)?$/) {
        $self->{aggregate} = 'min';
        return $self;
    } elsif ($input =~ /^av(g|e(rage)?)?$/) {
        $self->{aggregate} = 'average';
        return $self;
    }

    return undef;
}

sub _extract_sort {
    my ($self, $input) = @_;
    return undef if !defined $input || ref($input) || $input eq '';

    if ($input =~ /^values?$/i) {
        $self->{sort} = 'value';
        return $self;
    } elsif ($input =~ /^counts?$/i) {
        $self->{sort} = 'count';
        return $self;
    } elsif ($input =~ /^scores?$/i) {
        $self->{sort} = 'score';
        return $self;
    } elsif ($input =~ /^(first|occur(rence)?s?)$/i) {
        $self->{sort} = 'first';
        return $self;
    } elsif ($input =~ /^last$/i) {
        $self->{sort} = 'last';
        return $self;
    }

    return undef;
}

sub _extract_order {
    my ($self, $input) = @_;
    return undef if !defined $input || ref($input) || $input eq '';

    if ($input =~ /^asc(end(ing)?)?$/i) {
        $self->{order} = 'asc';
        return $self;
    } elsif ($input =~ /^desc(end(ing)?)?$/i) {
        $self->{order} = 'desc';
        return $self;
    }

    return undef;
}

sub _extract_pos {
    my ($self, $input) = @_;
    return undef if !defined $input;

    if (ref $input eq 'ARRAY') {
        $self->{pos} ||= [];
        push @{$self->{pos}}, @$input;
        return $self;
    } elsif ($input =~ /^-?\d+$/) {
        $self->{pos} ||= [];
        push @{$self->{pos}}, $input;
        return $self;
    }

    return undef;
}

sub _extract_key {
    my ($self, $input) = @_;
    return undef if !defined $input;

    $self->{key} ||= [];
    push @{$self->{key}}, (ref($input) eq 'ARRAY' ? @$input : ($input));
    return $self;
}

=head1 AUTHOR

Mahiro Ando, C<<  >>

=head1 LICENSE AND COPYRIGHT

Copyright 2012 Mahiro Ando.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;