File Coverage

blib/lib/Medical/Growth/NHANES_2000.pm

Criterion	Covered	Total	%
statement	69	71	97.1
branch	29	30	96.6
condition	15	18	83.3
subroutine	12	12	100.0
pod	4	4	100.0
total	129	135	95.5

#!/usr/bin/env perl

use 5.010;
use strict;
use warnings;

package Medical::Growth::NHANES_2000;

our ($VERSION) = '1.10';

use Moo::Lax;    # Vanilla Moo considered harmful
use Carp qw(croak);

use Module::Runtime;
use Module::Pluggable
  require     => 1,
  search_path => 'Medical::Growth::NHANES_2000',
  except      => 'Medical::Growth::NHANES_2000::Base';

sub measure_classes {
    shift->plugins;
}

sub measure_class_name_for {
    my ( $self, %criteria ) = @_;
    my ( $measure, $norm, $ages, $sex, $class );

    $criteria{age_group} //= $criteria{age} if exists $criteria{age};
    croak('Need to specify measure, age_group, and sex')
      unless exists $criteria{measure}
      and exists $criteria{age_group}
      and exists $criteria{sex};

    if (   $criteria{measure} =~ /^(\w+)(?:\s+|_)(?:for|by)(?:\s+|_)(\w+)/i
        or $criteria{measure} =~
        /^(Head Circumference)(?:\s+|_)(?:for|by)(?:\s+|_)(Age)/i )
    {
        ( $measure, $norm ) = ( $1, $2 );
    }
    elsif ( $criteria{measure} =~ /(\w+)\s+(\w+)/i ) {
        ( $measure, $norm ) = ( $1, $2 );
    }
    elsif (
        $criteria{measure} =~
        /^(Weight|Wg?t|Height|Hg?t|Stature|Stat|Length|Len|BMI|Head|HC|OFC)
          (Age|Height|Hg?t|Length|Len)/ix
      )
    {
        ( $measure, $norm ) = ( $1, $2 );
    }
    else {
        croak "Don't understand measure spec '$criteria{measure}'";
    }

    if ( $criteria{age_group} =~ /^(?:infant|toddler|recumbent|neonat)/i ) {
        $ages = 'Infant';
    }
    elsif ( $criteria{age_group} =~ /^(?:child|school|adol)/i ) {
        $ages = 'Child';
    }
    elsif ( $criteria{age_group} =~ /^[0-9.]+$/
        and ( $criteria{age_group} eq '0' or $criteria{age_group} > 0 ) )
    {
        $ages = $criteria{age_group} >= 24 ? 'Child' : 'Infant';
    }
    else {
        croak "Don't understand age group '$criteria{age_group}'";
    }

    # Sigh - 5.18 makes this warn
    no if $] >= 5.017011, warnings => 'experimental::smartmatch';

    given ($measure) {
        when (/^W/i)          { $measure = 'Weight'; }
        when (/^O|^Hea|^HC/i) { $measure = 'HC'; }
        when (/^[HLS]/i) { $measure = $ages eq 'Infant' ? 'Length' : 'Height'; }
        when (/^B/i)     { $measure = 'BMI'; }
        default {
            croak "Don't understand measure name '$measure' in "
              . "'$criteria{measure}'";
        }
    }

    given ($norm) {
        when (/^A/i) { $norm = 'Age'; }
        when (/^[HL]/i) { $norm = $ages eq 'Infant' ? 'Length' : 'Height'; }
        default {
            croak "Don't understand norm name in " . "'$criteria{measure}'";
        }
    }

    if ( $criteria{sex} =~ /^[MB1]/i ) {
        $sex = 'Male';
    }
    elsif ( $criteria{sex} =~ /^[FG2]/i ) {
        $sex = 'Female';
    }
    else {
        croak "Don't understand sex '$criteria{sex}'";
    }

    $class =
        'Medical::Growth::NHANES_2000::'
      . $measure . '_for_'
      . $norm . '::'
      . $ages . '::'
      . $sex;
    return $class;
}

sub have_measure_class_for {
    my $self  = shift;
    my $class = $self->measure_class_name_for(@_);
    return unless $class; # Never happens in this class; just kind to subclasses
    eval { Module::Runtime::use_module($class) } or undef;
}

sub measure_class_for {
    my $self  = shift;
    my $class = $self->measure_class_name_for(@_);
    Module::Runtime::use_module($class)->new;
}

1;

__END__