plan
tests
=> 7;
use
t::TestAM
qw(chapter_3_train chapter_3_test)
;
test_config_info();
my
$am
= Algorithm::AM->new(
training_set
=> chapter_3_train(),
);
my
$result
=
$am
->classify(chapter_3_test->get_item(0));
test_statistical_summary(
$result
);
test_aset_summary(
$result
);
test_gang_summary(
$result
);
test_undefined_result(
$am
);
test_scores(
$result
);
sub
test_config_info {
my
$train
= chapter_3_train();
my
$item
= Algorithm::AM::DataSet::Item->new(
features
=> [
qw(a b c)
],
comment
=>
'comment'
,
class
=>
'e'
,
);
subtest
'configuration info string'
=>
sub
{
plan
tests
=> 2;
my
$result
= Algorithm::AM::Result->new(
test_item
=>
$item
,
given_excluded
=> 1,
cardinality
=> 3,
exclude_nulls
=> 1,
count_method
=>
'linear'
,
test_in_train
=> 1,
training_set
=>
$train
);
my
$info
= ${
$result
->config_info};
my
$expected
=
<<'END_INFO';
+---------------------------+----------------+
| Option | Setting |
+---------------------------+----------------+
| Given context | a b c, comment |
| Nulls | exclude |
| Gang | linear |
| Test item in training set | yes |
| Test item excluded | yes |
| Size of training set | 5 |
| Number of active features | 3 |
+---------------------------+----------------+
END_INFO
is_string_nows(
$info
,
$expected
,
'given/nulls excluded, linear, test in train'
)
or note
$info
;
$result
= Algorithm::AM::Result->new(
given_excluded
=> 0,
cardinality
=> 3,
test_item
=>
$item
,
exclude_nulls
=> 0,
count_method
=>
'squared'
,
test_in_train
=> 0,
training_set
=>
$train
,
);
$info
= ${
$result
->config_info};
$expected
=
<<'END_INFO';
+---------------------------+----------------+
| Option | Setting |
+---------------------------+----------------+
| Given context | a b c, comment |
| Nulls | include |
| Gang | squared |
| Test item in training set | no |
| Test item excluded | no |
| Size of training set | 5 |
| Number of active features | 3 |
+---------------------------+----------------+
END_INFO
is_string_nows(
$info
,
$expected
,
'given/nulls included, linear, test not in train'
)
or note
$info
;
};
return
;
}
sub
test_statistical_summary{
my
(
$result
) =
@_
;
subtest
'statistical summary'
=>
sub
{
plan
tests
=> 4;
my
$stats
= ${
$result
->statistical_summary};
my
$expected
=
<<'END_STATS';
Statistical Summary
+-------+-------+------------+
| Class | Score | Percentage |
+-------+-------+------------+
| e | 4 | 30.769 |
| r | 9 | 69.231 |
+-------+-------+------------+
| Total | 13 | |
+-------+-------+------------+
Expected class: r
Correct class predicted.
END_STATS
is_string_nows(
$stats
,
$expected
,
'statistical summary'
)
or note
$stats
;
{
no
warnings
'redefine'
;
local
*Algorithm::AM::Result::result
=
sub
{
return
'incorrect'
;
};
$stats
= ${
$result
->statistical_summary};
$expected
=
<<'END_STATS';
Statistical Summary
+-------+-------+------------+
| Class | Score | Percentage |
+-------+-------+------------+
| e | 4 | 30.769 |
| r | 9 | 69.231 |
+-------+-------+------------+
| Total | 13 | |
+-------+-------+------------+
Expected class: r
Incorrect class predicted.
END_STATS
is_string_nows(
$stats
,
$expected
,
'statistical summary (incorrect class)'
) or
note
$stats
;
}
{
no
warnings
'redefine'
;
local
*Algorithm::AM::Result::result
=
sub
{
return
'tie'
;
};
$stats
= ${
$result
->statistical_summary};
$expected
=
<<'END_STATS';
Statistical Summary
+-------+-------+------------+
| Class | Score | Percentage |
+-------+-------+------------+
| e | 4 | 30.769 |
| r | 9 | 69.231 |
+-------+-------+------------+
| Total | 13 | |
+-------+-------+------------+
Expected class: r
Prediction is a tie.
END_STATS
is_string_nows(
$stats
,
$expected
,
'statistical summary (tie)'
) or
note
$stats
;
}
my
$item
= new_item(
features
=> [
qw(3 1 2)
],
comment
=>
'test item comment'
);
$result
=
$am
->classify(
$item
);
$stats
= ${
$result
->statistical_summary};
$expected
=
<<'END_STATS';
Statistical Summary
+-------+-------+------------+
| Class | Score | Percentage |
+-------+-------+------------+
| e | 4 | 30.769 |
| r | 9 | 69.231 |
+-------+-------+------------+
| Total | 13 | |
+-------+-------+------------+
Expected class unknown
END_STATS
is_string_nows(
$stats
,
$expected
,
'statistical summary (unlabeled)'
) or
note
$stats
;
};
return
;
}
sub
test_aset_summary {
my
(
$result
) =
@_
;
my
$set
= ${
$result
->analogical_set_summary};
my
$expected
=
<<'END_SET';
Analogical Set
Total Frequency = 13
+-------+---------------------+-------+------------+
| Class | Item | Score | Percentage |
+-------+---------------------+-------+------------+
| e | myFirstCommentHere | 4 | 30.769 |
| r | myThirdCommentHere | 2 | 15.385 |
| r | myFourthCommentHere | 3 | 23.077 |
| r | myFifthCommentHere | 4 | 30.769 |
+-------+---------------------+-------+------------+
END_SET
is_string_nows(
$set
,
$expected
,
'analogical set printout'
) or
note
$set
;
return
;
}
sub
test_gang_summary {
my
(
$result
) =
@_
;
subtest
'gang printing'
=>
sub
{
plan
tests
=> 3;
my
$gang
= ${
$result
->gang_summary(0)};
my
$expected
=
<<'END_GANG';
+------------+-------+-----------+-------+-------+
| Percentage | Score | Num Items | Class | |
| Context | | | | 3 1 2 |
+------------+-------+-----------+-------+-------+
**************************************************
| 61.538 | 8 | | | 3 1 * |
+------------+-------+-----------+-------+-------+
| 30.769 | 4 | 1 | e | |
| 30.769 | 4 | 1 | r | |
**************************************************
| 23.077 | 3 | | | * 1 2 |
+------------+-------+-----------+-------+-------+
| 23.077 | 3 | 1 | r | |
**************************************************
| 15.385 | 2 | | | * * 2 |
+------------+-------+-----------+-------+-------+
| 15.385 | 2 | 1 | r | |
+------------+-------+-----------+-------+-------+
END_GANG
is_string_nows(
$gang
,
$expected
,
'gang summary without items'
) or note
$gang
;
$gang
= ${
$result
->gang_summary(1)};
$expected
=
<<'END_GANG';
+------------+-------+-----------+-------+-------+---------------------+
| Percentage | Score | Num Items | Class | | Item Comment |
| Context | | | | 3 1 2 | |
+------------+-------+-----------+-------+-------+---------------------+
************************************************************************
| 61.538 | 8 | | | 3 1 * | |
+------------+-------+-----------+-------+-------+---------------------+
| 30.769 | 4 | 1 | e | | |
| | | | | 3 1 0 | myFirstCommentHere |
| 30.769 | 4 | 1 | r | | |
| | | | | 3 1 1 | myFifthCommentHere |
************************************************************************
| 23.077 | 3 | | | * 1 2 | |
+------------+-------+-----------+-------+-------+---------------------+
| 23.077 | 3 | 1 | r | | |
| | | | | 2 1 2 | myFourthCommentHere |
************************************************************************
| 15.385 | 2 | | | * * 2 | |
+------------+-------+-----------+-------+-------+---------------------+
| 15.385 | 2 | 1 | r | | |
| | | | | 0 3 2 | myThirdCommentHere |
+------------+-------+-----------+-------+-------+---------------------+
END_GANG
is_string_nows(
$gang
,
$expected
,
'gang summary with items'
) or note
$gang
;
my
$mini_finn_data
= dataset_from_file(
path
=> path(
$Bin
,
'data'
,
'finnverb_mini.txt'
),
format
=>
'nocommas'
,
);
my
$am
= Algorithm::AM->new(
training_set
=>
$mini_finn_data
,
);
$result
=
$am
->classify(
$mini_finn_data
->get_item(0));
$gang
= ${
$result
->gang_summary()};
ok(
$gang
=~ /\QA A 0 * 0 * 0 * * A\E/,
'features with "false" value are printed'
) or note
$gang
;
};
return
;
}
sub
test_undefined_result {
my
(
$am
) =
@_
;
my
$item
= new_item(
features
=> [
qw(3 1 2)
],
comment
=>
'test item comment'
);
my
$result
=
$am
->classify(
$item
);
is(
$result
->result,
undef
,
'result is undef for unlabeled item'
);
}
sub
test_scores {
my
(
$result
) =
@_
;
is_deeply(
$result
->scores, {
'e'
=> 4,
'r'
=> 9},
'scores'
) or note explain
$result
->scores;
cmp_deeply(
$result
->scores_normalized,
{
'e'
=> num(.3076923, .00001),
'r'
=> num(.6923077, .00001)},
'normalized scores'
) or
note explain
$result
->scores_normalized;
}