File Coverage

blib/lib/Algorithm/AM/Result.pm

Criterion	Covered	Total	%
statement	242	245	98.7
branch	46	50	92.0
condition	5	9	55.5
subroutine	17	17	100.0
pod	6	6	100.0
total	316	327	96.6

# encapsulate information about a single classification result
package Algorithm::AM::Result;
use strict;
use warnings;
our $VERSION = '3.13';
# ABSTRACT: Store results of an AM classification
use Text::Table;

#pod =head2 SYNOPSIS
#pod
#pod   use Algorithm::AM;
#pod
#pod   my $am = Algorithm::AM->new('finnverb', -commas => 'no');
#pod   my ($result) = $am->classify;
#pod   print @{ $result->winners };
#pod   print $result->statistical_summary;
#pod
#pod =head2 DESCRIPTION
#pod
#pod This package encapsulates all of the classification information
#pod generated by L, including the assigned class,
#pod score to each class, gang effects, analogical sets,
#pod and timing information. It also provides several methods for
#pod generating printable reports with this information.
#pod
#pod Note that the words 'score' and 'point' are used here to represent
#pod whatever count is assigned by analogical modeling during
#pod classification. This can be either pointers or occurrences. For an
#pod explanation of this, see L.
#pod
#pod All of the scores returned by the methods here are scalars with
#pod special PV and NV values. You should excercise caution when doing
#pod calculations with them. See L for more
#pod information.
#pod
#pod =cut

## TODO: variables consider exporting someday
## @itemcontextchain
## %itemcontextchainhead
## %context_to_class
## %context_size
use Class::Tiny qw(
    exclude_nulls
    given_excluded
    cardinality
    test_in_train
    test_item
    count_method

    start_time
    end_time

    training_set

    scores
    high_score
    total_points
    winners
    is_tie
    result

    scores_normalized
), {
    'scores_normalized' => sub {
        my ($self) = @_;
        my $total_points = $self->total_points;
        my $scores = $self->scores;
        my $normalized = {};
        for my $class (keys %$scores){
            $normalized->{$class} = $scores->{$class} / $total_points
        }
        return $normalized;
    },
};
use Carp 'croak';
use Algorithm::AM::BigInt 'bigcmp';

# For printing percentages in reports
my $percentage_format = '%.3f';

#pod =head1 REPORT METHODS
#pod
#pod The methods below return human eye-friendly reports about the
#pod classification. The return value is a reference, so it must be
#pod dereferenced for printing like so:
#pod
#pod  print ${ $result->statistical_summary };
#pod
#pod =head2 C
#pod
#pod Returns a scalar (string) ref containing information about the
#pod configuration at the time of classification. Information from the
#pod following accessors is included:
#pod
#pod     exclude_nulls
#pod     given_excluded
#pod     cardinality
#pod     test_in_train
#pod     test_item
#pod     count_method
#pod
#pod =cut
sub config_info {
    my ($self) = @_;
    my @headers = ('Option', 'Setting');
    my @rows = (
        [ "Given context", (join ' ', @{$self->test_item->features}) .
            ', ' . $self->test_item->comment],
        [ "Nulls", ($self->exclude_nulls ? 'exclude' : 'include')],
        [ "Gang",  $self->count_method],
        [ "Test item in training set", ($self->test_in_train ? 'yes' : 'no')],
        [ "Test item excluded", ($self->given_excluded ? 'yes' : 'no')],
        [ "Size of training set", $self->training_set->size ],
        [ "Number of active features", $self->cardinality ],
    );
    my @table = _make_table(\@headers, \@rows);
    my $info = join '', @table;
    return \$info;
}

# input several variables from AM's guts (sum, pointers,
# itemcontextchainhead and itemcontextchain). Calculate the
# prediction statistics, and
# store information needed for computing analogical sets.
# Set result to tie/correct/incorrect and also is_tie if
# expected class is provided, and high_score, scores, winners, and
# total_points.
sub _process_stats {
    my ($self, $sum, $pointers,
        $itemcontextchainhead, $itemcontextchain, $context_to_class,
        $raw_gang, $active_feats, $context_size) = @_;
    my $total_points = $pointers->{grand_total};
    my $max = '';
    my @winners;
    my %scores;

    # iterate all possible classes and store the ones that have a
    # non-zero score. Store the high-scorers, as well.
    # 1) find which one(s) has the highest score (the prediction) and
    # 2) print out the ones with scores (probability of prediction)
    for my $class_index (1 .. $self->training_set->num_classes) {
        my $class_score;
        # skip classes with no score
        next unless $class_score = $sum->[$class_index];

        my $class = $self->training_set->_class_for_index($class_index);
        $scores{$class} = $class_score;

        # check if the class has the highest score, or ties for it
        do {
            my $cmp = bigcmp($class_score, $max);
            if ($cmp > 0){
                @winners = ($class);
                $max = $class_score;
            }elsif($cmp == 0){
                push @winners, $class;
            }
        };
    }

    # set result to tie/correct/incorrect after comparing
    # expected/actual class labels. Only do this if the expected
    # class label is known.
    if(my $expected = $self->test_item->class){
        if(exists $scores{$expected} &&
                bigcmp($scores{$expected}, $max) == 0){
            if(@winners > 1){
                $self->result('tie');
            }else{
                $self->result('correct');
            }
        }else{
            $self->result('incorrect');
        }
    }
    if(@winners > 1){
        $self->is_tie(1);
    }
    $self->high_score($max);
    $self->scores(\%scores);
    $self->winners(\@winners);
    $self->total_points($total_points);
    $self->{pointers} = $pointers;
    $self->{itemcontextchainhead} = $itemcontextchainhead;
    $self->{itemcontextchain} = $itemcontextchain;
    $self->{context_to_class} = $context_to_class;
    $self->{raw_gang} = $raw_gang;
    $self->{active_feats} = $active_feats;
    $self->{context_size} = $context_size;
    return;
}

#pod =head2 C
#pod
#pod Returns a scalar reference (string) containing a statistical summary
#pod of the classification results. The summary includes all possible
#pod predicted classes with their scores and percentage scores and the
#pod total score for all classes. Whether the predicted class
#pod is correct/incorrect/a tie of some sort is also included, if the
#pod test item had a known class.
#pod
#pod =cut
sub statistical_summary {
    my ($self) = @_;
    my %scores = %{$self->scores};
    my $total_points = $self->total_points;

    # Make a table with information about predictions for different
    # classes. Each row contains a class name, the score,
    # and the percentage predicted.
    my @rows;
    for my $class (sort keys %scores){
        push @rows, [ $class, $scores{$class},
            sprintf($percentage_format,
                100 * $scores{$class} / $total_points) ];
    }
    # add a Total row
    push @rows, [ 'Total', $total_points ];

    my @table = _make_table(['Class', 'Score', 'Percentage'],
        \@rows);
    # copy the rule from the first row into the second to last row
    # to separate the Total row
    splice(@table, $#table - 1, 0, $table[0]);

    my $info = "Statistical Summary\n";
    $info .= join '', @table;
    # the predicted class (the one with the highest score)
    # and the result (correct/incorrect/tie).
    if ( defined (my $expected = $self->test_item->class) ) {
        $info .= "Expected class: $expected\n";
        my $result = $self->result;
        if ( $result eq 'correct') {
            $info .= "Correct class predicted.\n";
        }elsif($result eq 'tie'){
            $info .= "Prediction is a tie.\n";
        }else {
            $info .= "Incorrect class predicted.\n";
        }
    }else{
        $info .= "Expected class unknown\n";
    }
    return \$info;
}

#TODO: the keys for this set don't seem to make any sense.
sub analogical_set {
    my ($self) = @_;
    if(!exists $self->{_analogical_set}){
        $self->_calculate_analogical_set;
    }
    # make a safe copy
    my %set = %{$self->{_analogical_set}};
    return \%set;
}

#pod =head2 C
#pod
#pod Returns a scalar reference (string) containing the analogical set,
#pod meaning all items that contributed to the predicted class, along
#pod with the amount contributed by each item (score and
#pod percentage overall). Items are ordered by appearance in the data
#pod set.
#pod
#pod =cut
sub analogical_set_summary {
    my ($self) = @_;
    my $set = $self->analogical_set;
    my $total_points = $self->total_points;

    # Make a table for the analogical set. Each row contains an
    # item with its class, comment, score, and the percentage
    # of total score contributed.
    my @rows;
    foreach my $id (sort keys %$set){
        my $entry = $set->{$id};
        my $score = $entry->{score};
        push @rows, [
            $entry->{item}->class,
            $entry->{item}->comment,
            $score,
            sprintf($percentage_format, 100 * $score / $total_points)
        ];
    }
    my @table = _make_table(
        ['Class', 'Item', 'Score', 'Percentage'], \@rows);
    my $info = "Analogical Set\nTotal Frequency = $total_points\n";
    $info .= join '', @table;
    return \$info;
}

# calculate and store analogical effects in $self->{_analogical_set}
sub _calculate_analogical_set {
    my ($self) = @_;
    my $train = $self->training_set;
    my %set;
    foreach my $context ( keys %{$self->{pointers}} ) {
        next unless
            exists $self->{itemcontextchainhead}->{$context};
        for (
            my $index = $self->{itemcontextchainhead}->{$context};
            defined $index;
            $index = $self->{itemcontextchain}->[$index]
        )
        {
            my $item = $train->get_item($index);
            $set{$item->id} = {
                item => $item,
                score => $self->{pointers}->{$context}
            };
        }
    }
    $self->{_analogical_set} = \%set;
    return;
}

sub gang_effects {
    my ($self) = @_;
    if(!$self->{_gang_effects}){
        $self->_calculate_gangs;
    }
    return $self->{_gang_effects};
}

#pod =head2 C
#pod
#pod Returns a scalar reference (string) containing the gang effects on the
#pod final class prediction.
#pod
#pod A single boolean parameter can be provided to turn on list printing,
#pod meaning gang items items are printed. This is false (off) by default.
#pod
#pod =cut
sub gang_summary {
    my ($self, $print_list) = @_;
    my $test_item = $self->test_item;

    my $gangs = $self->gang_effects;

    # Make a table for the gangs with these rows:
    #   Percentage
    #   Score
    #   Num
    #   Class
    #   Features
    #   item comment
    my @rows;
    # first row is a header with test item for easy reference
    push @rows, [
        'Context',
        undef,
        undef,
        undef,
        @{$test_item->features},
    ];

    # store the number of rows added for each gang
    # will help with printing later
    my @gang_rows;
    my $current_row = -1;
    # add information for each gang; sort by order of highest to
    # lowest effect
    foreach my $gang (@$gangs){
        $current_row++;
        $gang_rows[$current_row]++;
        my $features = $gang->{features};
        # add the gang supracontext, effect and score
        push @rows, [
            sprintf($percentage_format, 100 * $gang->{effect}),
            $gang->{score},
            undef,
            undef,
            # print undefined feature slots as asterisks
            map {length($_) ? $_ : '*'} @$features
        ];
        # add each class in the gang, along with the total number
        # and effect of the gang items supporting it
        for my $class (sort keys %{ $gang->{class} }){
            $gang_rows[$current_row]++;
            push @rows, [
                sprintf($percentage_format,
                    100 * $gang->{class}->{$class}->{effect}),
                $gang->{class}->{$class}->{score},
                scalar @{ $gang->{data}->{$class} },
                $class,
                undef
            ];
            if($print_list){
                # add the list of items in the given context
                for my $item (@{ $gang->{data}->{$class} }){
                    $gang_rows[$current_row]++;
                    push @rows, [
                        undef,
                        undef,
                        undef,
                        undef,
                        @{ $item->features },
                        $item->comment,
                    ];
                }
            }
        }
    }

    # construct the table from the rows
    my @headers = (
        \'| ',
        'Percentage' => \' | ',
        'Score' => \' | ',
        'Num Items' => \' | ',
        'Class' => \' | ',
        ('' => \' ') x @{$test_item->features}
    );
    pop @headers;
    if($print_list){
        push @headers, \' | ', 'Item Comment';
    }
    push @headers, \' |';
    my @rule = qw(- +);
    my $table = Text::Table->new(@headers);
    $table->load(@rows);
    # main header
    $current_row = 0;
    my $return = $table->rule(@rule) .
        $table->title .
        $table->body($current_row) .
        $table->rule(@rule);
    $current_row++;
    # add info with a header for each gang
    for my $num (@gang_rows){
        # a row of '*' separates each gang
        $return .= $table->rule('*','*') .
            $table->body($current_row) .
            $table->rule(@rule);
        $current_row++;
        for(1 .. $num - 1){
            $return .= $table->body($current_row);
            $current_row++;
        }
    }
    $return .= $table->rule(@rule);
    return \$return;
}

sub _calculate_gangs {
    my ($self) = @_;
    my $train = $self->training_set;
    my $total_points = $self->total_points;
    my $raw_gang = $self->{raw_gang};
    my @gangs;

    foreach my $context (keys %{$raw_gang})
    {
        my $gang = {};
        my @features = $self->_unpack_supracontext($context);
        # for now, store gangs by the supracontext printout
        my $key = join ' ', map {length($_) ? $_ : '-'} @features;
        $gang->{score} = $raw_gang->{$context};
        $gang->{effect} = $raw_gang->{$context} / $total_points;
        $gang->{features} = \@features;

        my $num_class_pointers = $self->{pointers}->{$context};
        # if the supracontext is homogenous
        if ( my $class_index = $self->{context_to_class}->{$context} ) {
            # store a 'homogenous' key that indicates this, besides
            # indicating the unanimous class prediction.
            my $class = $train->_class_for_index($class_index);
            $gang->{homogenous} = $class;
            my @data;
            for (
                my $index = $self->{itemcontextchainhead}->{$context};
                defined $index;
                $index = $self->{itemcontextchain}->[$index]
              )
            {
                push @data, $train->get_item($index);
            }
            $gang->{data}->{$class} = \@data;
            $gang->{size} = scalar @data;
            $gang->{class}->{$class}->{score} = $num_class_pointers;
            $gang->{class}->{$class}->{effect} =
                $gang->{effect};
        }
        # for heterogenous supracontexts we have to store data for
        # each class
        else {
            $gang->{homogenous} = 0;
            # first loop through the data and sort by class, also
            # finding the total gang size
            my $size = 0;
            my %data;
            for (
                my $index = $self->{itemcontextchainhead}->{$context};
                defined $index;
                $index = $self->{itemcontextchain}->[$index]
              )
            {
                my $item = $train->get_item($index);
                push @{ $data{$item->class} }, $item;
                $size++;
            }
            $gang->{data} = \%data;
            $gang->{size} = $size;

            # then store aggregate statistics for each class
            for my $class (keys %data){
                $gang->{class}->{$class}->{score} = $num_class_pointers;
                $gang->{class}->{$class}->{effect} =
                    # score*num_data/total
                    @{ $data{$class} } * $num_class_pointers / $total_points;
            }
        }
        push @gangs, $gang;
    }

    # sort by score and then alphabetically by class labels
    @gangs = sort{
        bigcmp($b->{score}, $a->{score}) ||
        (join '', sort keys %{ $b->{class} })
        cmp
        (join '', sort keys %{ $a->{class} })} @gangs;
    $self->{_gang_effects} = \@gangs;
    return;
}

# Unpack and return the supracontext features.
# Blank entries mean the variable may be anything, e.g.
# ('a' 'b' '') means a supracontext containing items
# wich have ('a' 'b' whatever) as variable values.
sub _unpack_supracontext {
    my ($self, $context) = @_;
    my @context_list = unpack "S!4", $context;
    my @alist = @{$self->{active_feats}};
    my (@features) = @{ $self->test_item->features };
    my $exclude_nulls = $self->exclude_nulls;
    my $j = 1;
    foreach my $a (reverse @alist) {
        my $partial_context = pop @context_list;
        for ( ; $a ; --$a ) {
            if($exclude_nulls){
                ++$j while !defined $features[ -$j ];
            }
            $features[ -$j ] = '' if $partial_context & 1;
            $partial_context >>= 1;
            ++$j;
        }
    }
    return @features;
}

# mostly by Ovid:
# http://use.perl.org/use.perl.org/_Ovid/journal/36762.html
# Return table rows with a nice header and column separators
sub _make_table {
    my ( $headers, $rows ) = @_;

    my @rule      = qw(- +);
    my @headers   = \'| ';
    push @headers => map { $_ => \' | ' } @$headers;
    pop  @headers;
    push @headers => \' |';

    unless ('ARRAY' eq ref $rows
        && 'ARRAY' eq ref $rows->[0]
        && @$headers == @{ $rows->[0] }) {
        croak(
            "make_table() rows must be an AoA with rows being same size as headers"
        );
    }
    my $table = Text::Table->new(@headers);
    $table->rule(@rule);
    $table->body_rule(@rule);
    $table->load(@$rows);

    return $table->rule(@rule),
        $table->title,
        $table->rule(@rule),
        map({ $table->body($_) } 0 .. @$rows),
        $table->rule(@rule);
}

1;

__END__