Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
package Algorithm::ToNumberMunger;
use 5.006;
use strict;
use warnings;
use Carp qw(carp croak);
use Scalar::Util qw(looks_like_number);
=head1 NAME
Algorithm::ToNumberMunger - Compile declarative specs into closures that munge raw values into numbers.
=head1 VERSION
Version 0.0.1
=cut
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my ( $spec, $where ) = @_;
my $map = $spec->{map};
croak "enum munger$where requires a 'map' hashref"
unless ref $map eq 'HASH';
for my $k ( keys %$map ) {
croak "enum munger$where: map value for '$k' ('"
. ( defined $map->{$k} ? $map->{$k} : 'undef' )
. "') is not numeric"
unless looks_like_number( $map->{$k} );
}
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "enum munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
# Copy so a later edit of the caller's spec cannot mutate a live munger.
my %m = %$map;
return sub {
my ($v) = @_;
return $m{$v} if defined $v && exists $m{$v};
return $default if $has_default;
croak "enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
};
} ## end sub _build_enum
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my $counts = $spec->{counts};
croak "frozen_freq_map munger$where requires a non-empty 'counts' hashref"
unless ref $counts eq 'HASH' && %$counts;
my $sum = 0;
for my $k ( keys %$counts ) {
my $c = $counts->{$k};
croak "frozen_freq_map munger$where: count for '$k' ('"
. ( defined $c ? $c : 'undef' )
. "') is not a non-negative number"
unless looks_like_number($c) && $c >= 0;
$sum += $c;
}
my $V = keys %$counts;
carp "frozen_freq_map munger$where: 'counts' has $V keys; a table this large bloats "
. "info.json -- consider the 'hash' munger for unbounded cardinality"
if $V > $FROZEN_FREQ_MAP_WARN_KEYS;
my $total = defined $spec->{total} ? $spec->{total} : $sum;
croak "frozen_freq_map munger$where: 'total' must be numeric"
unless looks_like_number($total);
croak "frozen_freq_map munger$where: 'total' ($total) must be >= sum of counts ($sum)"
if $total < $sum;
my $mode = defined $spec->{mode} ? $spec->{mode} : 'neg_log_prob';
croak "frozen_freq_map munger$where: unknown mode '$mode' (known: " . join( ', ', sort keys %FREQ_MODE ) . ')'
unless $FREQ_MODE{$mode};
my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
croak "frozen_freq_map munger$where: 'smoothing' must be a non-negative number"
unless looks_like_number($s) && $s >= 0;
my $unseen = defined $spec->{unseen} ? $spec->{unseen} : 'rare';
croak "frozen_freq_map munger$where: 'unseen' must be 'rare' or a number"
unless $unseen eq 'rare' || looks_like_number($unseen);
# An unseen value under neg_log_prob has probability s/denom; with no
# smoothing that is 0 and -ln(0) is infinite, which would poison the column.
# Refuse to build rather than emit inf.
croak "frozen_freq_map munger$where: mode 'neg_log_prob' with unseen => 'rare' needs "
. "smoothing > 0 (an unseen value would otherwise be infinitely surprising)"
if $mode eq 'neg_log_prob' && $unseen eq 'rare' && $s == 0;
# Smoothed-probability denominator, treating "unseen" as one extra bucket.
my $denom = $total + $s * ( $V + 1 );
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
=cut
# Shared closure for the status-class mungers registered from %STATUS_PROTO.
sub _status_class_munger {
my ( $proto, $lo, $hi, $div, $spec, $where ) = @_;
my $strict = $spec->{strict} ? 1 : 0;
return sub {
my ($v) = @_;
croak "${proto}_enum munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a numeric status code"
unless looks_like_number($v);
croak "${proto}_enum munger$where: status code '$v' is out of range " . "($lo-$hi)"
if $strict && ( $v < $lo || $v > $hi );
return int( $v / $div );
};
} ## end sub _status_class_munger
=head2 mgcp_enum
{ munger => 'mgcp_enum' }
{ munger => 'mgcp_enum', strict => 1 }
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# MGCP's strict range is [100,599] union [800,899] -- 8xx package-specific
# codes are real, 6xx/7xx are not -- which %STATUS_PROTO's single [lo, hi]
# cannot express, hence this dedicated builder.
sub _build_mgcp_enum {
my ( $spec, $where ) = @_;
my $strict = $spec->{strict} ? 1 : 0;
return sub {
my ($v) = @_;
croak "mgcp_enum munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a numeric status code"
unless looks_like_number($v);
croak "mgcp_enum munger$where: status code '$v' is out of range " . "(100-599 or 800-899)"
if $strict && !( ( $v >= 100 && $v <= 599 ) || ( $v >= 800 && $v <= 899 ) );
return int( $v / 100 );
};
} ## end sub _build_mgcp_enum
=head2 dns_rcode_enum
{ munger => 'dns_rcode_enum' }
{ munger => 'dns_rcode_enum', default => -1 }
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
$BUILDERS{"${name}_enum"} = sub { _named_enum_munger( $name, $e, @_ ) };
}
# Shared closure for the named-map enums registered from %NAMED_ENUM.
sub _named_enum_munger {
my ( $name, $e, $spec, $where ) = @_;
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "${name}_enum munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
my ( $map, $numeric ) = @{$e}{qw(map numeric)};
return sub {
my ($v) = @_;
if ( defined $v ) {
return $v + 0 if $numeric && looks_like_number($v);
my $k = lc $v;
return $map->{$k} if exists $map->{$k};
}
return $default if $has_default;
croak "${name}_enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
}; ## end sub
} ## end sub _named_enum_munger
=head2 bool
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my $sum = 0;
for my $g ( keys %$counts ) {
$n = length $g unless defined $n;
croak "ngram munger$where: all 'counts' keys must be the same length "
. "(that length is n); got '$g' alongside a $n-gram"
unless length($g) == $n;
my $c = $counts->{$g};
croak "ngram munger$where: count for '$g' ('"
. ( defined $c ? $c : 'undef' )
. "') is not a non-negative number"
unless looks_like_number($c) && $c >= 0;
$sum += $c;
} ## end for my $g ( keys %$counts )
croak "ngram munger$where: 'counts' keys must be at least 1 character"
unless $n >= 1;
my $V = keys %$counts;
carp "ngram munger$where: 'counts' has $V keys; a table this large bloats info.json"
if $V > $FROZEN_FREQ_MAP_WARN_KEYS;
my $total = defined $spec->{total} ? $spec->{total} : $sum;
croak "ngram munger$where: 'total' must be numeric"
unless looks_like_number($total);
croak "ngram munger$where: 'total' ($total) must be >= sum of counts ($sum)"
if $total < $sum;
my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
croak "ngram munger$where: 'smoothing' must be a number > 0 "
. '(an unseen gram would otherwise be infinitely surprising)'
unless looks_like_number($s) && $s > 0;
my $fold = exists $spec->{fold_case} ? ( $spec->{fold_case} ? 1 : 0 ) : 1;
# Same smoothed-probability scheme as frozen_freq_map, "unseen" as one extra
# bucket; surprisal precomputed per listed gram.
my $denom = $total + $s * ( $V + 1 );
my %si = map { $_ => -log( ( $counts->{$_} + $s ) / $denom ) } keys %$counts;
my $unseen = -log( $s / $denom );
return sub {
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
sub _build_count {
my ( $spec, $where ) = @_;
my $of = $spec->{of};
croak "count munger$where requires a non-empty 'of' string"
unless defined $of && length $of;
my $plus = defined $spec->{plus} ? $spec->{plus} : 0;
croak "count munger$where: 'plus' must be numeric"
unless looks_like_number($plus);
# index() beats a global regex match here: no pattern engine, and no
# per-call list of matches just to count them. Advancing by length($of)
# keeps the non-overlapping semantics m//g had.
my $oflen = length $of;
return sub {
my ($v) = @_;
my $s = defined $v ? "$v" : '';
my $n = 0;
my $p = 0;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
sub _build_bucket {
my ( $spec, $where ) = @_;
my $bounds = $spec->{bounds};
croak "bucket munger$where requires a non-empty 'bounds' arrayref"
unless ref $bounds eq 'ARRAY' && @$bounds;
my @b = @$bounds;
for my $i ( 0 .. $#b ) {
croak "bucket munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
unless looks_like_number( $b[$i] );
croak "bucket munger$where: 'bounds' must be strictly ascending"
if $i && $b[$i] <= $b[ $i - 1 ];
}
return sub {
my ($v) = @_;
croak "bucket munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
my $idx = 0;
for my $bound (@b) {
last if $v < $bound;
$idx++;
}
return $idx;
}; ## end sub
} ## end sub _build_bucket
=head2 quantile
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
sub _build_quantile {
my ( $spec, $where ) = @_;
my $bounds = $spec->{bounds};
croak "quantile munger$where requires a 'bounds' arrayref with at least 2 values"
unless ref $bounds eq 'ARRAY' && @$bounds >= 2;
my @b = @$bounds;
for my $i ( 0 .. $#b ) {
croak "quantile munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
unless looks_like_number( $b[$i] );
croak "quantile munger$where: 'bounds' must be strictly ascending"
if $i && $b[$i] <= $b[ $i - 1 ];
}
my $segs = $#b;
return sub {
my ($v) = @_;
croak "quantile munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return 0 if $v <= $b[0];
return 1 if $v >= $b[-1];
my $i = 0;
$i++ while $v >= $b[ $i + 1 ];
return ( $i + ( $v - $b[$i] ) / ( $b[ $i + 1 ] - $b[$i] ) ) / $segs;
}; ## end sub
} ## end sub _build_quantile
=head2 scale
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
C<[0, 1]>. C<min> and C<max> must differ. With a true C<clamp>, results are
pinned into C<[0, 1]> so out-of-range inputs cannot escape the unit interval.
=cut
sub _build_scale {
my ( $spec, $where ) = @_;
my ( $min, $max ) = @{$spec}{qw(min max)};
croak "scale munger$where requires numeric 'min' and 'max'"
unless looks_like_number($min) && looks_like_number($max);
my $range = $max - $min;
croak "scale munger$where: 'min' and 'max' must differ"
if $range == 0;
my $clamp = $spec->{clamp} ? 1 : 0;
return sub {
my ($v) = @_;
croak "scale munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
my $s = ( $v - $min ) / $range;
if ($clamp) { $s = 0 if $s < 0; $s = 1 if $s > 1; }
return $s;
};
} ## end sub _build_scale
=head2 zscore
{ munger => 'zscore', mean => 42.0, std => 7.5 }
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
are supplied (this module does not learn them) so munging stays stateless and a
row can be munged in isolation.
=cut
sub _build_zscore {
my ( $spec, $where ) = @_;
my ( $mean, $std ) = @{$spec}{qw(mean std)};
croak "zscore munger$where requires numeric 'mean' and 'std'"
unless looks_like_number($mean) && looks_like_number($std);
croak "zscore munger$where: 'std' must be non-zero"
if $std == 0;
return sub {
my ($v) = @_;
croak "zscore munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return ( $v - $mean ) / $std;
};
} ## end sub _build_zscore
=head2 log
{ munger => 'log' } # natural log
{ munger => 'log', offset => 1 } # log1p-style, so 0 is allowed
{ munger => 'log', base => 10, offset => 1 }
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
shifted value must be strictly positive or the input croaks. C<base> defaults to
natural log.
=cut
sub _build_log {
my ( $spec, $where ) = @_;
my $offset = exists $spec->{offset} ? $spec->{offset} : 0;
croak "log munger$where: 'offset' must be numeric"
unless looks_like_number($offset);
my $ln_base;
if ( defined $spec->{base} ) {
croak "log munger$where: 'base' must be numeric and > 0 and != 1"
unless looks_like_number( $spec->{base} )
&& $spec->{base} > 0
&& $spec->{base} != 1;
$ln_base = log( $spec->{base} );
}
return sub {
my ($v) = @_;
croak "log munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
my $x = $v + $offset;
croak "log munger$where: value+offset must be > 0 (got $x)"
unless $x > 0;
my $r = log($x);
$r /= $ln_base if defined $ln_base;
return $r;
}; ## end sub
} ## end sub _build_log
=head2 clamp
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
sub _build_clamp {
my ( $spec, $where ) = @_;
my ( $min, $max ) = @{$spec}{qw(min max)};
my $have_min = defined $min;
my $have_max = defined $max;
croak "clamp munger$where needs at least one of 'min' or 'max'"
unless $have_min || $have_max;
croak "clamp munger$where: 'min' must be numeric"
if $have_min && !looks_like_number($min);
croak "clamp munger$where: 'max' must be numeric"
if $have_max && !looks_like_number($max);
croak "clamp munger$where: 'min' must be <= 'max'"
if $have_min && $have_max && $min > $max;
return sub {
my ($v) = @_;
croak "clamp munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
$v = $min if $have_min && $v < $min;
$v = $max if $have_max && $v > $max;
return $v;
};
} ## end sub _build_clamp
=head2 num
{ munger => 'num', base => 16 } # '0x1a' or '1a' -> 26
{ munger => 'num' } # plain numeric coercion
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my ( $spec, $where ) = @_;
my $base = defined $spec->{base} ? $spec->{base} : 10;
croak "num munger$where: 'base' must be an integer from 2 to 36"
unless $base =~ /\A[0-9]+\z/ && $base >= 2 && $base <= 36;
if ( $base == 10 ) {
return sub {
my ($v) = @_;
croak "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return $v + 0;
};
}
my %digit;
my $i = 0;
$digit{$_} = $i++ for ( '0' .. '9', 'a' .. 'z' );
# Strip only the base's own conventional prefix; for other bases a letter
# like 'b' is just a digit, so there is nothing to disambiguate.
my $prefix
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
=cut
sub _build_ratio {
my ( $spec, $where, $nsrc ) = @_;
croak "ratio munger$where takes exactly 2 source fields (numerator, denominator), not $nsrc"
unless $nsrc == 2;
my $zero = defined $spec->{zero} ? $spec->{zero} : 0;
croak "ratio munger$where: 'zero' must be numeric"
unless looks_like_number($zero);
return sub {
for my $v (@_) {
croak "ratio munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
}
return $zero if $_[1] == 0;
return $_[0] / $_[1];
};
} ## end sub _build_ratio
# op => fold over the already numeric-checked source values. A table so the
# error message can enumerate them and a new op is one line.
my %COMBINE_OPS = (
sum => sub { my $t = 0; $t += $_ for @_; return $t },
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
croak "combine munger$where requires an 'op' (one of: " . join( ', ', sort keys %COMBINE_OPS ) . ')'
unless defined $op && length $op;
my $fold = $COMBINE_OPS{$op}
or croak "combine munger$where: unknown op '$op' (known: " . join( ', ', sort keys %COMBINE_OPS ) . ')';
croak "combine munger$where: op 'diff' takes exactly 2 source fields, not $nsrc"
if $op eq 'diff' && $nsrc != 2;
return sub {
for my $v (@_) {
croak "combine munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
}
return $fold->(@_);
};
} ## end sub _build_combine_op
=head2 bit
{ munger => 'bit', mask => '0x12' } # SYN or ACK set?
{ munger => 'bit', mask => '0x02', mode => 'all' } # the SYN bit itself
{ munger => 'bit', mode => 'popcount' } # how many flags at all
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
return 'reserved' if $discard;
return 'global';
} ## end sub _ip6_class
sub _build_ip_class {
my ( $spec, $where ) = @_;
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "ip_class munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
return sub {
my ($v) = @_;
my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
if ($fam) {
return $IP_CLASS{ $fam == 4 ? _ip4_class($p) : _ip6_class($p) };
}
return $default if $has_default;
croak "ip_class munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
};
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my $mask
= $fam == 4
? ( $len == 0 ? 0 : ( 0xffffffff << ( 32 - $len ) ) & 0xffffffff )
: _v6_mask($len);
push @match, [ $fam, $p & $mask, $mask ];
} ## end for my $i ( 0 .. $#$nets )
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "cidr munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
return sub {
my ($v) = @_;
my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
if ($fam) {
for my $i ( 0 .. $#match ) {
my ( $f, $network, $mask ) = @{ $match[$i] };
next unless $f == $fam;
return $i
if $fam == 4
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
unless length $socket;
my $prefix = defined $spec->{prefix} ? $spec->{prefix} : '';
croak "eps munger$where: 'prefix' may not contain whitespace or control " . 'characters'
if $prefix =~ /[\s[:cntrl:]]/;
my $mark = exists $spec->{mark} ? ( $spec->{mark} ? 1 : 0 ) : 1;
my $timeout = defined $spec->{timeout} ? $spec->{timeout} : 5;
croak "eps munger$where: 'timeout' must be a positive number"
unless looks_like_number($timeout) && $timeout > 0;
my $on_error = defined $spec->{on_error} ? $spec->{on_error} : 'die';
croak "eps munger$where: 'on_error' must be 'die' or a number"
unless $on_error eq 'die' || looks_like_number($on_error);
return ( $socket, $prefix, $mark, $timeout, $on_error );
} ## end sub _eps_spec
my %EPS_READ = map { $_ => 1 } qw(rate count total);
sub _build_eps {
my ( $spec, $where ) = @_;
croak "eps munger$where: 'parts' is for the multi-output form (needs " . "'into'); use 'read' for a single column"
( run in 0.690 second using v1.01-cache-2.11-cpan-6aa56a78535 )