view release on metacpan or  search on metacpan

lib/Algorithm/AM/Result.pm  view on Meta::CPAN

    return;
}

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

#pod =head2 C<gang_summary>
#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{