File Coverage

blib/lib/Medical/Growth/NHANES_2000/Base.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	16	16	100.0
condition	6	6	100.0
subroutine	17	17	100.0
pod	5	5	100.0
total	115	115	100.0

#!/usr/bin/env perl

use 5.010;
use strict;
use warnings;

package Medical::Growth::NHANES_2000::Base;

our ($VERSION) = '1.00';

use Scalar::Util ();
use Exporter;
use Moo::Lax;    # Vanilla Moo considered harmful

use Statistics::Standard_Normal qw(z_to_pct pct_to_z);
use namespace::clean;

extends 'Medical::Growth::Base';

# Ugly hack here to accommodate the fact that MooX::ClassAttribute
# doesn't handle inheriting/overriding class attrs.
# If you're writing your own, and can afford to use Moose,
# MooseX::ClassAttribute is cleaner.
sub _declare_params_LMS {
    my $class = shift;
    no strict 'refs';
    *{ $class . '::_params_LMS' } = sub {
        state $lms_values = shift->_build_params_LMS;
        $lms_values;
      }
}

sub _build_params_LMS {
    my $class = shift;
    my (@data);

    foreach my $r ( @{ $class->read_data } ) {
        push @data,
          {
            index => $r->[0],
            L     => $r->[1],
            M     => $r->[2],
            S     => $r->[3]
          };
    }
    @data = sort { $a->{index} <=> $b->{index} } @data;
    \@data;
}

sub lookup_LMS {
    my ( $self, $index ) = @_;
    return unless defined $index;
    my $list = $self->_params_LMS;
    my $i    = 0;

    return if $index < $list->[0]->{index} or $index > $list->[-1]->{index};

    $i++ while $list->[$i]->{index} < $index;
    $i-- if $i and $index != $list->[$i]->{index};

    # Exact match, just return current values
    return @{ $list->[$i] }{qw/L M S/} if $index == $list->[$i]->{index};

    # Between two indices; return interpolated values
    my ( $lo_i, $lo_l, $lo_m, $lo_s ) = @{ $list->[$i] }{qw/index L M S/};
    my ( $hi_i, $hi_l, $hi_m, $hi_s ) = @{ $list->[ $i + 1 ] }{qw/index L M S/};
    my $frac = ( $index - $lo_i ) / ( $hi_i - $lo_i );
    return (
        $lo_l + $frac * ( $hi_l - $lo_l ),
        $lo_m + $frac * ( $hi_m - $lo_m ),
        $lo_s + $frac * ( $hi_s - $lo_s )
    );
}

sub z_for_value {
    my ( $self, $value, $index ) = @_;
    my ( $l,    $m,     $s )     = $self->lookup_LMS($index);

    return unless $m;    # Off end of range

    if ($l) {
        return ( ( $value / $m )**$l - 1 ) / ( $l * $s );
    }
    else {
        return log( $value / $m ) / $s;
    }
}

sub pct_for_value {
    my ( $self, $value, $index ) = @_;
    return z_to_pct( $self->z_for_value( $value, $index ) );
}

sub value_for_z {
    my ( $self, $z_score, $index ) = @_;
    my ( $l,    $m,       $s )     = $self->lookup_LMS($index);

    return unless $m;    # Off end of range

    if ($l) {
        return $m * ( 1 + $l * $s * $z_score )**( 1 / $l );
    }
    else {
        return $m * exp( $s * $z_score );
    }
}

sub value_for_pct {
    my ( $self, $pct, $index ) = @_;
    $self->value_for_z( pct_to_z($pct), $index );
}

1;

__END__