File Coverage

blib/lib/Data/FeatureFactory.pm

Criterion	Covered	Total	%
statement	568	667	85.1
branch	321	416	77.1
condition	106	133	79.7
subroutine	23	24	95.8
pod	1	7	14.2
total	1019	1247	81.7

package Data::FeatureFactory;

use strict;
use Carp;
use File::Basename;
use Scalar::Util;

our $VERSION = '0.0404';
my $PATH = &{ sub { return dirname( (caller)[1] ) } };
my $OPEN_OPTIONS;
our $CURRENT_FEATURE;
my %KNOWN_FORMATS = map {;$_=>1} qw/binary normal numeric/;

# check if perl can open files in utf8
{
    my $fh;
    undef $@;
    eval { open $fh, '<:encoding(utf8)', $0 };
    if ($@) {
        $OPEN_OPTIONS = '';
        warn qq{the open's :encoding directive not supported by your perl ($]). Files won't be opened in utf8 format.};
    }
    else { $OPEN_OPTIONS = ':encoding(utf8)' }
    close $fh;
}

sub new : method {
    my ($class, $args) = @_;
    $class = ref $class if ref $class;
    croak "Too many parameters to $class->new" if @_ > 2;
    my $self = bless +{}, $class;

    if (defined $args) {
        croak "The parameter to ${class}->new must be a hashref with options or nothing" if ref $args ne 'HASH';
        my %accepted_option = map {;$_=>1} qw(N/A);
        while (my ($k, $v) = each %$args) {
            if (not exists $accepted_option{$k}) {
                croak "Unexpected option '$k' passed to ${class}->new"
            }
            if ($k eq 'N/A') {
                $self->{'N/A'} = "$v";
            }
        }
    }

    no strict 'refs';
    if (not defined @{$class."::features"}) {
        croak "\@${class}::features not defined";
    }
    our @features;
    *features = \@{$class."::features"};
    use strict;
    if (not @features) {
        warn "$class has empty set of features. Not much fun";
    }
    $self->{'features'} = [];
    my %feat_named;
    $self->{'feat_named'} = \%feat_named;
    my @featkeys;
    $self->{'featkeys'} = \@featkeys;
    $self->{'caller_path'} = dirname( (caller)[1] );

    my %supported_option = ( map {;$_=>1} qw(code default format label name postproc range type values values_file) );
    my %accepted_option  = ( map {;$_=>1} qw(cat2num cat2num_dyna num2cat num2cat_dyna num_values_fh values_ordered) );

    # parse the @features array
    for my $original_feature (@features) {
        my $feature = { %$original_feature };
        if (not exists $feature->{'name'}) {
            croak q{There was a feature without a name. Each record in the @features array must be a hashref with a 'name' field at least};
        }
        my $name = $feature->{'name'};
        if (exists $feat_named{$name}) {
            croak "Feature $name specified twice in \@${class}::features";
        }
        push @{ $self->{'features'} }, $feature;
        $feat_named{$name} = $feature;
        push @featkeys, $name;

        # Check if there aren't illegal options
        for (keys %$feature) {
            if (not exists $supported_option{$_}) {
                if (exists $accepted_option{$_}) {
                    warn "Option '$_' you specified for feature '$name' is not supported. Be sure you know what you are doing"
                }
                else {
                    croak "Unrecognized option '$_' specified for feature '$name'";
                }
            }
        }

        # Check if a postprocessing subroutine is declared
        # If it's a CODEref, we're OK. Else try to load it.
        if (exists $feature->{'postproc'} and ref $feature->{'postproc'} ne 'CODE') {
            my $postproc = $feature->{'postproc'};
            no strict 'refs';
            my $postprocsub = \&{$postproc};
            undef $@;
            eval { $postprocsub->() };
            if ($@ =~ /Undefined subroutine/) {
                my ($package_name) = $postproc =~ /^( (?: \w+:: )+ )/x;
                my $ppname;
                if (defined $package_name and length $package_name > 0) {
                    $package_name =~ s/::$//;
                    local @INC = (@INC, $self->{'caller_path'});
                    undef $@;
                    eval "require $package_name";
                    if ($@) {
                        warn "Failed loading module '$package_name'";
                    }
                    $ppname = $postproc;
                }
                else {
                    $ppname = $class.'::'.$postproc;
                }
                $postprocsub = \&{$ppname};
                undef $@;
                eval { $postprocsub->() };
                if ($@ =~ /^Undefined subroutine/) {
                    croak "Couldn't load postprocessing function '$postproc' ($@)"
                }
            }
            elsif ($@ =~ /^Undefined subroutine/) {
                croak "Couldn't load postprocessing function '$postproc' ($@)"
            }
            $feature->{'postproc'} = $postprocsub;
        }

        # Check if values are specified and if they are a list of values.
        if (exists $feature->{'values'}) {
            if (exists $feature->{'values_file'}) {
                croak "Values specified both explicitly and by file for '$name'"
            }
            my $values = $feature->{'values'};
            if (ref $values eq 'HASH') {    # OK, do nothing
            }
            elsif (ref $values eq 'ARRAY') {    # Convert the list to a hash.
                my %values = map {;$_ => 1} @$values;
                $feature->{'values_ordered'} = $values;
                $feature->{'values'} = \%values;
            }
            else {
                my $type;
                if (ref $values) {
                    $type = lc(ref $values).'ref';
                }
                else {
                    $type = lc(ref \$values);
                }
                croak "The values must be specified as an arrayref or hashref, not $type"
            }
        }

        if (exists $feature->{'values_file'}) {
            my $values_fn = $feature->{'values_file'};
            my $opened = open my $values_fh, '<'.$OPEN_OPTIONS, $values_fn;
            if (not $opened) {
                open $values_fh, '<'.$OPEN_OPTIONS, $self->{'caller_path'}.'/'.$values_fn
                    or croak "Couldn't open file '$values_fn' specifying values for $name"
            }
            my %values;
            my @values;
            while (<$values_fh>) {
                chomp;
                $values{$_} = 1;
                push @values, $_;
            }
            close $values_fh;
            $feature->{'values'} = \%values;
            $feature->{'values_ordered'} = \@values;
        }

        if (exists $feature->{'range'}) {
            if (exists $feature->{'values'}) {
                croak "Both range and values specified for feature '$name'"
            }
            $feature->{'range'} =~ /^ (.+?) \s* \.{2,} \s* (.+) $/x
            or croak "Malformed range '$$feature{range}' of feature '$name'. Should be in format '0 .. 5'";
            my $l = $1+0;
            my $r = $2+0;
            if (not $l < $r) {
                croak "Invalid range '$$feature{range}' specified for feature '$name'. The left boundary must be lesser than the right one"
            }

            if ($feature->{'type'} =~ /^int/i) {
                $feature->{'values'} = {map {;$_ => 1} $l .. $r};
                $feature->{'values_ordered'} = [$l .. $r];
            }
            elsif ($feature->{'type'} =~ /^num/i) {
                $feature->{'range_l'} = $l;
                $feature->{'range_r'} = $r;
            }
        }

        if (exists $feature->{'default'}) {
            if (not exists $feature->{'values'} and not exists $feature->{'range_l'}) {
                croak "Default value '$$feature{default}' but no values specified for feature '$name'"
            }
        }

        if (exists $feature->{'type'}) {
            my $type = lc substr $feature->{'type'}, 0, 3;
            my $type_OK = grep {$type eq $_} qw(boo int num cat);
            if (not $type_OK) {
                croak "The type of a feature, if given, should be 'integer', 'numeric', or 'categorial'"
            }
            $feature->{'type'} = $type;

            # check if the values comply to the type
            if ($type eq 'boo') {
                if (exists $feature->{'values'}) {
                    my @values = exists $feature->{'values_ordered'} ? @{ $feature->{'values_ordered'} } : values(%{ $feature->{'values'} });
                    if (@values > 2) {
                        my $num_values = @values;
                        croak "More than two values ($num_values) specified for feature '$name'"
                    }
                    my ($false, $true);
                    # boolify the values
                    for (@values) {
                        if ($_) {
                            if (defined $true) {
                                croak "True value (literal: '$true', '$_') for feature '$name' specified multiple times"
                            }
                            $true = $_;
                        }
                        else {
                            if (defined $false) {
                                croak "False value (literal: '$false', '$_') for feature '$name' specified multiple times"
                            }
                            $false = $_;
                        }
                        $_ = $_ ? 1 : 0;
                    }
                    if (exists $feature->{'values_ordered'}) {
                        $feature->{'values_ordered'} = \@values;
                    }
                    $feature->{'values'} = +{ map {;$_=>1} @values };
                }
                else {
                    $feature->{'values'} = {0 => 1, 1 => 1};
                    $feature->{'values_ordered'} = [0,1];
                }
                if (exists $feature->{'default'}) {
                    my $def = $feature->{'default'};
                    my @vals = values %{ $feature->{'values'} };
                    if (@vals > 1) {
                        croak "Default value '$def' specified for boolean feature '$name' which has both values allowed"
                    }
                    unless ($def xor $vals[0]) {
                        my $val = $def ? 'true' : 'false';
                        croak "Default and allowed value are both $val for feature '$name'";
                    }
                    $feature->{'default'} = $def ? 1 : 0;
                }
            }
            elsif ($type eq 'int') {
                if (exists $feature->{'values'}) {
                    my @values = exists $feature->{'values_ordered'} ? @{ $feature->{'values_ordered'} } : values(%{ $feature->{'values'} });
                    # integrify the values
                    for (@values) {
                        $_ = int $_;
                    }
                    if (exists $feature->{'values_ordered'}) {
                        $feature->{'values_ordered'} = \@values;
                    }
                    $feature->{'values'} = +{ map {;$_=>1} @values };
                }
                if (exists $feature->{'default'}) {
                    $feature->{'default'} = int $feature->{'default'};
                }
            }
            elsif ($type eq 'num') {
                # numify the features, producing warnings if used
                if (exists $feature->{'values'}) {
                    my @values = exists $feature->{'values_ordered'} ? @{ $feature->{'values_ordered'} } : values(%{ $feature->{'values'} });
                    for (@values) {
                        $_ += 0;
                    }
                    if (exists $feature->{'values_ordered'}) {
                        $feature->{'values_ordered'} = \@values;
                    }
                    $feature->{'values'} = +{ map {;$_=>1} @values };
                }
                if (exists $feature->{'default'}) {
                    $feature->{'default'} += 0;
                }
            }
        }

        if (exists $feature->{'format'}) {
            my $format = $feature->{'format'};
            if (not $format =~ /^ (?: normal | numeric | binary ) $/x) {
                croak "Invalid format '$format' specified for feature '$name'. Please specify 'normal', 'numeric' or 'binary'"
            }
            if (not exists $feature->{'values'} and $format eq 'binary') {
                croak "Feature '$name' has format: 'binary' specified but doesn't have values specified"
            }
        }

        # find the actual code of the feature
        my $code;
        no strict 'refs';
        if (exists $feature->{'code'}) {
            $code = $feature->{'code'};
            if (ref $code ne 'CODE') {
                croak "'code' was specified for feature '$name' but it's not a coderef"
            }
        }
        elsif (%{$class.'::features'} and exists ${$class.'::features'}{$name}) {
            $code = ${$class.'::features'}{$name};
            if (ref $code ne 'CODE') {
                croak "Found $name in \%${class}::features but it's not a coderef"
            }
        }
        else {
            $code = *{$class.'::'.$name}{CODE};
            if (ref $code ne 'CODE') {
                croak "Couldn't find the code (function) for feature '$name'. Define it as a function '$name' in the '$class' package. Stopped"
            }
        }
        $feature->{'code'} = $code;

        if (exists $feature->{'label'}) {
            my $label = $feature->{'label'};
            if (ref $label eq 'ARRAY') {
                $feature->{'label'} = {map {;uc($_) => 1} @$label};
            }
            elsif (ref $label) {
                croak "Label must be a string or an array of strings - feature '$name' has a ".ref($label).'ref'
            }
            else {
                $feature->{'label'} = {uc($label) => 1};
            }
        }
    }
#    print map "*$_\n", map keys(%$_), @{ $self->{'features'} };
    return $self
}

sub expand_names : method {
    my ($self, $featnames) = @_;
    if (not ref $featnames and exists $self->{expand_names_cache}{$featnames}) {
        return $self->{expand_names_cache}{$featnames}
    }
    my $orig_featnames = $featnames;
    my @featkeys = @{ $self->{'featkeys'} };
    my %feat_named = %{ $self->{'feat_named'} };

    if ($featnames eq 'ALL') {
        $featnames = \@featkeys;
    }
    elsif (ref $featnames eq 'ARRAY') {
#        $featnames = [@$featnames]; # make a copy
    }
    # features given by labels
    elsif ($featnames !~ /[[:lower:]]/ and $featnames =~ /[[:upper:]]/) {
        my @all_labels = split /\s+/, $featnames;
        my @plus_labels  = map {s/^\+//; $_}  grep {substr($_, 0, 1) ne '-'} @all_labels;
        my @minus_labels = map {substr $_, 1} grep {substr($_, 0, 1) eq '-'} @all_labels;
        # Specifying just '-LABEL' means all but those that have LABEL
        if (@plus_labels == 0 and @minus_labels > 0) {
            @plus_labels = qw(ALL);
        }
        if (grep {$_ eq 'ALL'} @minus_labels) {
            croak "Label 'ALL' is special and can't be used with the minus sign, as in $featnames"
        }
        $featnames = [];
        for my $featkey (@featkeys) {
            my $feature = $feat_named{ $featkey };
            my $included = grep { $_ eq 'ALL' or exists $feature->{'label'}{$_} } @plus_labels;
            my $excluded = grep {                exists $feature->{'label'}{$_} } @minus_labels;
            push @$featnames, $featkey if $included and not $excluded;
        }
    }
    else {
        $featnames = ["$featnames"];
    }

    if (not ref $orig_featnames) { $self->{expand_names_cache}{$orig_featnames} = $featnames }
    return $featnames
}

sub evaluate : method {
    my ($self, $featnames, $format, @args) = @_;
    my $class = ref $self;

    $featnames = $self->expand_names($featnames);
    my @feats;
    if (exists $self->{evaluate_featnames_cache}{"@$featnames"}) {
        @feats = @{ $self->{evaluate_featnames_cache}{"@$featnames"} };
    }
    else {
        my %feat_named = %{ $self->{feat_named} };
        for my $featname (@$featnames) {
            if (not exists $feat_named{$featname}) {
                croak "Feature '$featname' you wish to evaluate was not found among known features (these are: @{$self->{featkeys}})"
            }
            push @feats, $feat_named{$featname};
        }
        $self->{evaluate_featnames_cache}{"@$featnames"} = \@feats;
    }

    if (not exists $KNOWN_FORMATS{$format}) {
        croak "Unknown format: '$format'. Please specify one of: @{[keys %KNOWN_FORMATS]}."
    }
    for my $feature (@feats) {
        $self->_create_mapping($feature, $format);
    }

    if (@args == 0) {
        warn 'No arguments specified for the features.';
    }
    ### Done argument checking.

    ### Traverse the features and evaluate them
    my @rv;
    for my $feature (@feats) {
        my $name = $feature->{'name'};
        $CURRENT_FEATURE = $name;
        my $normrv = $feature->{'code'}(@args);
        undef $CURRENT_FEATURE;
        my $format = exists $feature->{'format'} ? $feature->{'format'} : $format;

        if (not defined $normrv and exists $self->{'N/A'}) {
            my $na = $self->{'N/A'};
            if (exists $feature->{'type'} and $feature->{'type'} eq 'boo') {
                push @rv, $na;
            }
            elsif ($format eq 'binary') {
                # take one of the vectors in cat2bin
                my @dummy = @{ (values %{ $feature->{'cat2bin'} })[0] };
                if (not @dummy) {
                    croak "Couldn't determine the length of bit vector for feature '$name',"
                         ."which was about to be evaluated in binary and returned undef"
                }
                push @rv, map $na, @dummy;
            }
            else {
                push @rv, $na;
            }
        }
        else {
            # Normally format the value. The eval babble is there to take care of unexpected values.
            undef $@;
            my @val = eval { _format_value($feature, $normrv, $format, @args) };
            if ($@) {
                if (ref $@ and $@->isa('Data::FeatureFactory::SoftError')) {
                    warn ${$@};
                    return
                }
                else {
                    die $@
                }
            }
            push @rv, @val;
        }
    }

    return @rv[0 .. $#rv]
}

sub _format_value {
    my ($feature, $normrv, $format, @args) = @_;
    my @rv;
    my $name = $feature->{'name'};
    local $\; local $,;

    # convert to number if appropriate
    if (exists $feature->{'type'}) {
        my $type = $feature->{'type'};
        if ($type eq 'num' or $type eq 'int') {
            $normrv += 0;
        }
        if ($type eq 'int') {
            $normrv = int $normrv;
        }
        if ($type eq 'boo') {
            $normrv = $normrv ? 1 : 0;
        }
    }

    # check if the value is a legal one
    if (exists $feature->{'values'}) {
        if (exists $feature->{'values'}{$normrv}) {    # alles gute
        }
        elsif (exists $feature->{'default'}) {
            $normrv = $feature->{'default'};
        }
        else {
            die Data::FeatureFactory::SoftError->new("Feature '$name' returned unexpected value '$normrv' on arguments '@args'")
        }
    }
    # check the range for numeric features
    elsif (exists $feature->{'range_l'}) {
        if (not exists $feature->{'range_r'}) {
            die "feature '$name' has range_l but not range_r";
        }
        if ($normrv < $feature->{'range_l'}) {
            if (exists $feature->{'default'}) {
                $normrv = $feature->{'default'};
            }
            else {
                die Data::FeatureFactory::SoftError->new(
                    "Feature '$name' returned an unexpected value '$normrv' below the left allowed boundary '$$feature{range_l}'"
                )
            }
        }
        if ($normrv > $feature->{'range_r'}) {
            if (exists $feature->{'default'}) {
                $normrv = $feature->{'default'};
            }
            else {
                die Data::FeatureFactory::SoftError->new(
                    "Feature '$name' returned an unexpected value '$normrv' above the right allowed boundary '$$feature{range_r}'"
                )
            }
        }
    }

    if ($format eq 'normal') {
        if (exists $feature->{'postproc'}) {
            $normrv = $feature->{'postproc'}->($normrv);
        }
        @rv = ($normrv);
    }
    elsif ($format eq 'numeric') {
        if (exists $feature->{'type'} and $feature->{'type'} =~ /^( num | int | boo )$/x) {
            @rv = ($normrv);
        }
        elsif (exists $feature->{'cat2num'}) {
            if (not exists $feature->{'cat2num'}{$normrv}) {
                croak "Feature '$name' has the value '$normrv' for which there is no mapping to numbers"
            }
            @rv = ($feature->{'cat2num'}{$normrv});
        }
        else {  # dynamically creating the mapping
            my $n;
            if (exists $feature->{'cat2num_dyna'}{$normrv}) {
                $n = $feature->{'cat2num_dyna'}{$normrv};
            }
            else {
                $n = ++$feature->{'num_value_max'};
                $feature->{'cat2num_dyna'}{$normrv} = $n;
                $feature->{'num2cat_dyna'}{$n} = $normrv;
                my @toprint = ($normrv, $n);
                if (exists $feature->{'postproc'}) {
                    my $ppd = $feature->{'postproc'}->($normrv);
                    $feature->{'pp2cat_dyna'}{$ppd} = $normrv;
                    push @toprint, $ppd;
                }
                print {$feature->{'num_values_fh'}} join("\t", @toprint)."\n"
                or croak "Couldn't print the mapping of categorial value '$normrv' to numeric value '$n' for feature '$name' to a file ($!).\n"
                . 'Please provide a list of values for the feature to avoid this'
            }
            @rv = ($n);
        }
    }
    elsif ($format eq 'binary') {
        if (exists $feature->{'type'} and $feature->{'type'} eq 'boo') {
            @rv = ($normrv);
        }
        elsif (not exists $feature->{'cat2bin'}{$normrv}) {
            croak "No mapping for value '$normrv' to binary in feature '$name'"
        }
        else {
            @rv = @{ $feature->{'cat2bin'}{$normrv} };
        }
    }
    else {
        croak "Unrecognized format '$format'"
    }
    return @rv
}

sub _values_of {
    my ($feature) = @_;
    my @values;
    if (exists $feature->{'values_ordered'}) {
        @values = @{ $feature->{'values_ordered'} };
    }
    elsif (exists $feature->{'values'}) {
        @values = keys %{ $feature->{'values'} };
    }
    else {
        croak "Attempted to gather the values of feature '$$feature{name}', which has none specified"
    }
    if (exists $feature->{'default'} and not exists $feature->{'values'}{ $feature->{'default'} }) {
        push @values, $feature->{'default'};
    }
    return @values
}

sub _create_mapping : method {
    my ($class, $feature, $format) = @_;
    $class = ref $class if ref $class;
    if (exists $feature->{'format'} and $format ne 'postprocd') {
        $format = $feature->{'format'};
    }

    if (lc $format eq 'normal') {
    }
    elsif (lc $format eq 'numeric') {
        return if exists $feature->{'type'} and $feature->{'type'} eq 'num';
        return if exists $feature->{'type'} and $feature->{'type'} eq 'int';
        return if exists $feature->{'type'} and $feature->{'type'} eq 'boo';
        return if exists $feature->{'cat2num'}; # Blindly trusting that what we have here is a sane mapping from the original values to numbers
        my $name = $feature->{'name'};
        if (not exists $feature->{'values'}) {
            return if exists $feature->{'num_values_fh'};
            warn "Categorial feature '$name' is about to be evaluated numerically but has no set of values specified";
            (my $num_values_basename = $class.'__'.$name) =~ s/\W/_/g;
            $num_values_basename = '.FeatureFactory.'.$num_values_basename;
            my @filenames_to_try = (
                $PATH.'/'.$num_values_basename,
                $ENV{'HOME'}.'/'.$num_values_basename,
                '/tmp/'.$num_values_basename,
            );
            my $num_values_fh;
            my $opened;
            my $num_value_max = 0;
            FILENAME_R:
            for my $fn (@filenames_to_try) {
                $opened = open my $fh, '+<'.$OPEN_OPTIONS, $fn;
                if ($opened) {
                    local $_;   # for some reason, this is necessary to prevent crashes (Modification of read-only value) when e.g. in for(qw(a b)){ }
                    while (<$fh>) {
                        chomp;
                        my ($cat, $num, $ppd) = split /\t/;
                        $num_value_max = $num if $num > $num_value_max;
                        $feature->{'cat2num_dyna'}{$cat} = $num;
                        $feature->{'num2cat_dyna'}{$num} = $cat;
                        $feature->{'pp2cat_dyna' }{$ppd} = $cat if defined $ppd;
                    }
                    print STDERR "Saving the mapping for feature '$name' to file $fn\n";
                    $feature->{'num_values_fh'} = $fh;
                    last FILENAME_R
                }
            }
            # If there's no file to recover from, try to start a new one
            if (not $opened) { FILENAME_W: for my $fn (@filenames_to_try) {
                $opened = open my $fh, '>'.$OPEN_OPTIONS, $fn;
                if ($opened) {
                    print STDERR "Saving the mapping for feature '$name' to file $fn\n";
                    $feature->{'num_values_fh'} = $fh;
                    last FILENAME_W
                }
            }}
            if (not $opened) {
                delete $feature->{'num_values_fh'};
                croak "Couldn't open a file for saving the mapping the categories of feature '$name' to numbers. "
                . 'Please specify the values for the feature to avoid this'
            }
            $feature->{'num_value_max'} = $num_value_max;
        }
        else {  # Got values specified - create a mapping
            my @values = _values_of($feature);
            my $n = 1;
            for my $value (@values) {
                $feature->{'cat2num'}{$value} = $n;
                $feature->{'num2cat'}{$n} = $value;
            } continue {
                $n++;
            }
        }
    }
    elsif (lc $format eq 'binary') {
        return if exists $feature->{'type'} and $feature->{'type'} eq 'boo';
        return if exists $feature->{'cat2bin'};
        my $name = $feature->{'name'};
        if (not exists $feature->{'values_ordered'} and not exists $feature->{'values'}) {
            croak "Attempted to convert feature '$name' to binary without specifying its values";
        }

        my @values = _values_of($feature);

        my $n = 0;
        my @zeroes = (0) x scalar(@values);
        for my $value (@values) {
            my @vector = @zeroes;
            $vector[$n] = 1;
            $feature->{'cat2bin'}{$value} = \@vector;
            $feature->{'bin2cat'}{join(' ', @vector)} = $value;
        } continue {
            $n++;
        }
    }
    elsif ($format eq 'postprocd') {
        return if exists $feature->{'pp2cat'};
        my $name = $feature->{'name'};
        if (not exists $feature->{'postproc'}) {
            croak "Feature '$name' doesn't have a postprocessing function specified - can't create mapping from postprocessed values. Stopped"
        }
        my $ppfun = $feature->{'postproc'};
        my @values = _values_of($feature);
        my %pp2cat;
        for my $value (@values) {
            my $ppd = $ppfun->($value);
            $pp2cat{ $ppd } = $value;
        }
        $feature->{'pp2cat'} = \%pp2cat;
    }
    else {
        croak "Format '$format' not recognized - please specify 'normal', 'numeric', 'binary' or 'postprocd' (should have caught this earlier)"
    }
}

sub names : method {
    my ($self) = @_;
    return map $_->{'name'}, @{ $self->{'features'} }
}

sub _vector_length { # how many bits will the binary representation of this feature have
    my ($feature) = @_;
    if (exists $feature->{'type'} and $feature->{'type'} eq 'boo') {
        return 1
    }
    return scalar _values_of($feature)
}

sub _shift_value {
    my ($feature, $format, $values) = @_;
    if ($format ne 'binary') {
        return shift @$values
    }
    my $n = _vector_length($feature);
    if (@$values < $n) {
        croak "There's not enough fields left to shift a $format value (width $n) of feature '$$feature{name}' from a length "
        . scalar(@$values) . " list ('@$values')"
    }
    return splice @$values, 0, $n
}

sub _init_translation {
    my ($self, $names, $options) = @_;
    if (ref($names) ne 'ARRAY') {
        croak 'Names must be given by an arrayref'
    }
    if (ref($options) ne 'HASH') {
        croak 'Options must be given by a hashref'
    }

    my %accepted_options = map {;$_=>1} qw(
        names from_format to_format from_NA to_NA FS OFS header ignore
    );
    for (keys %$options) {
        if (not exists $accepted_options{$_}) {
            croak "Translate does not accept option '$_'. Accepted options are: ".join(' ', keys %accepted_options).'. Stopped'
        }
    }

    my $from_format = $options->{'from_format'};
    my $to_format   = $options->{'to_format'};
    for ($from_format, $to_format) {
        if (! m/^(?: normal | numeric | binary )$/x) {
            croak '{to,from}_format must be one of "normal", "numeric" or "binary"'
        }
    }

    if (exists $options->{'from_NA'} and exists $options->{'to_NA'}) {
    }
    elsif (exists $options->{'from_NA'} and exists $self->{'N/A'}) {
        $options->{'to_NA'}   = $self->{'N/A'};
    }
    elsif (exists $options->{'to_NA'}   and exists $self->{'N/A'}) {
        $options->{'from_NA'} = $self->{'N/A'};
    }
    elsif (exists $options->{'to_NA'}) {
        $options->{'from_NA'} = undef;
    }
    elsif (exists $options->{'from_NA'}) {
        croak 'from_NA specified but neither to_NA nor global N/A value specified'
    }
    elsif (exists $self->{'N/A'}) {
        $options->{'from_NA'} = $options->{'to_NA'} = $self->{'N/A'};
    }

    if (exists $options->{'header'} and not $options->{'header'}) {
        delete $options->{'header'};
    }

    if (exists $options->{'ignore'}) {
        my $ignore = $options->{'ignore'};
        $options->{'ignore'} = [];

        if (not ref $ignore) {
            $ignore = [$ignore];
        }

        if (ref($ignore) eq 'ARRAY') {
            my $has_non_nums = grep !Scalar::Util::looks_like_number($_), @$ignore;
            if ($has_non_nums) {
                warn 'Some of the specifications of columns to ignore are non-numeric'
            }
            for my $idx (@$ignore) {
                if ($idx < 0) {
                    croak "Negative column indices aren't currently supported. Trailing columns are ignored always. Stopped"
                }
                $options->{'ignore'}[ $idx ] = 1;
            }
        }
        else {
            croak 'Option "ignore" can only be a column number or an array thereof. Stopped'
        }

        # Remove the names of the columns to ignore if the names come from a header
        if (exists $options->{'header'}) {
            for my $idx (sort {$b <=> $a} @$ignore) {
                splice @$names, $idx, 1;
            }
        }
    }

    my (@features, @widths);
    my %names = map {;$_=>1} $self->names;
    for my $name (@$names) {
        if (not exists $names{$name}) {
            croak "Feature '$name' not found among ".join(' ', $self->names).". Stopped"
        }
        my $feature = $self->{'feat_named'}{ $name };
        $self->_create_mapping($feature, $from_format);
        $self->_create_mapping($feature, $to_format);
        if ($from_format eq 'normal' and exists $feature->{'postproc'}) {
            if (exists $feature->{'values'}) {
                $self->_create_mapping($feature, 'postprocd');
            }
            elsif (exists $feature->{'format'} or $to_format eq 'normal') {
                # translating normal -> normal -- kein problem
            }
            elsif (join(' ', sort $from_format, $to_format) eq 'normal numeric') {
                # translating with dynamic mapping
            }
            else {
                croak "Feature '$name' is postprocessed and about to be translated from normal but has no values specified. Stopped"
            }
        }
        push @features, $feature;
        my $bin = 0;
        if (exists $feature->{'format'} and $feature->{'format'} eq 'binary') {
            $bin = 1;
        }
        elsif (exists $feature->{'format'}) {}
        elsif ($from_format eq 'binary') {
            $bin = 1;
        }
        my $width = $bin ? _vector_length($feature) : 1;
        push @widths, $width;
    }
    return map [$names->[$_], $features[$_], $widths[$_]], 0 .. $#features
}

my %x2cat = (
    binary    => 'bin2cat',
    numeric   => 'num2cat',
    postprocd => 'pp2cat',
);

sub _translate_row : method {
    my ($self, $descrs, $values, $options) = @_;
    if (ref($values) ne 'ARRAY') {
        croak 'Values must be given by an arrayref'
    }
    if (@$values < @$descrs) {
        croak "There's not enough values in the \@values array (".scalar(@$values).") to match the number of features (".scalar(@$descrs).")";
    }
    my ($from_format, $to_format, $from_NA, $to_NA, $ignore) = @$options{qw(
         from_format   to_format   from_NA   to_NA   ignore)};

    my $coln = 0;
    my @rv;
    FEATNAME:
    for my $descr (@$descrs) {
        my ($name, $feature, $width) = @$descr;
        if (defined $ignore) {
            while (exists $ignore->[ $coln++ ]) {
                push @rv, shift @$values;
            }
        }
        my $from_format = exists $feature->{'format'} ? $feature->{'format'} : $from_format;
        my $to_format   = exists $feature->{'format'} ? $feature->{'format'} : $to_format;
        my @value = splice @$values, 0, $width;
        if (@value == 0) {
            croak "Zero-width value obtained for feature '$name'"
        }

        # Check if the value is N/A
        my $is_NA = 0;
        if (@value == 1) {
            my $value = $value[0];
            if (defined $from_NA and $value eq $from_NA) {
                $is_NA = 1;
            }
            elsif (defined $to_NA and not defined $value and not defined $from_NA) {
                $is_NA = 1;
            }
        }
        else {
            if (defined $to_NA and not grep {defined $_} @value and not defined $from_NA) {
                $is_NA = 1;
            }
            elsif (defined $from_NA and not grep {$_ ne $from_NA} @value) {
                $is_NA = 1;
            }
        }

        # Append the N/A if appropriate
        if ($is_NA) {
            my $n = $to_format eq 'binary' ? _vector_length($feature) : 1;
            push @rv, ( ($to_NA) x $n );
            next FEATNAME
        }

        if ($from_format eq $to_format) {
            push @rv, @value;
            next FEATNAME
        }
        else {
            my $catval;
            my $from_format = $from_format;
            if ($from_format eq 'normal' and exists $feature->{'postproc'}) {
                $from_format = 'postprocd';
            }
            if ($from_format eq 'normal') {
                ($catval) = @value;
            }
            elsif ($from_format eq 'numeric' and exists $feature->{'type'} and $feature->{'type'} =~ /^(int|num|boo)$/) {
                ($catval) = @value;
            }
            elsif ($from_format eq 'binary' and exists $feature->{'type'} and $feature->{'type'} eq 'boo') {
                ($catval) = @value;
            }
            else {
                my $transfer = $x2cat{ $from_format };
                if (not defined $transfer) {
                    croak "Internal error: Unexpected value for \$from_format: '$from_format'"
                }
                if (not exists $feature->{ $transfer }) {
                    if (exists $feature->{ $transfer.'_dyna' }) {
                        $transfer = $transfer.'_dyna';
                    }
                    else {
                        croak "Cannot find mapping '$transfer' for feature '$name'"
                    }
                }
                my $valval = join(' ', @value);
                if (not exists $feature->{ $transfer }{ $valval }) {
                    my $hint = '';
                    if ($valval eq $feature->{'name'}) {
                        $hint = ". Maybe you forgot there was a header in your file? Stopped"
                    }
                    croak "Unexpected value '$valval' of feature '$name' for transfer '$transfer'$hint"
                }
                $catval = $feature->{ $transfer }{ $valval };
            }

            my @formatted = _format_value($feature, $catval, $to_format, 'NO_ARGS:TRANSLATING_ONLY');
            push @rv, @formatted;
        }
    }

    # Append the trailing columns
    push @rv, @$values;

    return @rv
}

sub translate_row : method {
    my ($self, $names, $values, $options) = @_;
    $names = $self->expand_names($names);
    my @descrs = $self->_init_translation($names, $options);
    $self->_translate_row(\@descrs, $values, $options);
}

sub translate : method {
    my ($self, $source, $sink, $options) = @_;
    local $\; local $,;
    if (not defined Scalar::Util::openhandle($source)) {
        croak 'Source must be given by an open filehandle'
    }
    if (not defined Scalar::Util::openhandle($sink)) {
        croak 'Destination must be given by an open filehandle'
    }
    if (ref($options) ne 'HASH') {
        croak 'Options must be given by a hashref'
    }
    my $ifs = $options->{'FS'};
    my $ofs = exists $options->{'OFS'} ? $options->{'OFS'} : $ifs;
    my @names;
    my @orig_header_fields;
    if (exists $options->{'names'}) {
        @names = @{ $self->expand_names($options->{'names'}) };
    }
    elsif (exists $options->{'header'} and $options->{'header'}) {
        my $row = <$source>;
        chomp $row;
        @names = split /(?:\Q$ifs\E)+/, $row;
        @orig_header_fields = @names;
    }
    else {
        croak 'No feature names specified for translate'
    }

    my @descrs = $self->_init_translation(\@names, $options);

    # Translate the header, if there's one.
    if (@orig_header_fields) {
        my $globbin = $options->{'to_format'} eq 'binary';
        my $last = pop @orig_header_fields;
        for my $field (@orig_header_fields) {
            my $nsep;
            if (not exists $self->{'feat_named'}{ $field }) {
                $nsep = 1;
            }
            else {
                my $feature = $self->{'feat_named'}{ $field };
                my $bin = (exists $feature->{'format'} and $feature->{'format'} eq 'binary' or $globbin);
                $nsep = $bin ? _vector_length($feature) : 1;
            }
            print {$sink} $field, $ofs x $nsep;
        }
        print {$sink} $last, "\n";
    }

    ROW:
    while (defined (my $row = <$source>)) {
        chomp $row;
        my @values = split /$ifs/, $row;
        undef $@;
        my @translated = eval { $self->_translate_row(\@descrs, \@values, $options) };
        warn("$@ (line $.)"), next ROW if $@;
        print {$sink} join($ofs, @translated), "\n";
    }
}

sub add_label {
    my ($feature, @labels) = @_;
    @labels = map uc($_), @labels;
    if (exists $feature->{'label'}) {
        if (ref($feature->{'label'}) eq 'ARRAY') {
            push @{ $feature->{'label'} }, @labels;
        }
        else {
            $feature->{'label'} = [$feature->{'label'}, @labels];
        }
    }
    else {
        $feature->{'label'} = [@labels];
    }
}

{
    package Data::FeatureFactory::SoftError;
    sub new {
        my ($class, $message) = @_;
        $message = "SoftError occurred" if not defined $message;
        return bless \$message, $class
    }
}

1

__END__