AI-MaxEntropy
view release on metacpan or search on metacpan
program manipulate samples more flexibly
- Replace Test::Differences with is_deeply in Test::More
0.10 Wed Feb 13 16:56:00 2008
- rewrite the log likelihood evaluation and smoothing by C, now
the ME learner should run more than 10 times faster than the
previous version
- add a new module AI::MaxEntropy::Util, which provides some
utilities for doing experiments with ME learners
- AI::MaxEntropy::see now accepts attribute-value style samples
- include Algorithm::Diff in the distribution for testing
0.02 Thu Feb 7 11:26:00 2008
- some tiny corrections :-P
0.01 Thu Feb 7 11:13:00 2008
- original version
inc/Module/AutoInstall.pm view on Meta::CPAN
my %FeatureMap = (
'' => 'Core Features', # XXX: deprecated
'-core' => 'Core Features',
);
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
my ( $PostambleActions, $PostambleUsed );
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
_init();
sub _accept_default {
$AcceptDefault = shift;
}
sub missing_modules {
return @Missing;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
}
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
elsif ( $arg =~ /^--check(?:deps)?$/ ) {
$CheckOnly = 1;
}
elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
$SkipInstall = 1;
}
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
}
}
# overrides MakeMaker's prompt() to automatically accept the default choice
sub _prompt {
goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
my ( $prompt, $default ) = @_;
inc/Module/AutoInstall.pm view on Meta::CPAN
ref($_)
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
: ''
}
map { +{@args}->{$_} }
grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
)[0]
);
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
my $default = 1;
my $conflict = 0;
if ( $feature =~ m/^-(\w+)$/ ) {
my $option = lc($1);
# check for a newer version of myself
_update_to( $modules, @_ ) and return if $option eq 'version';
# sets CPAN configuration options
inc/Module/AutoInstall.pm view on Meta::CPAN
unshift @$modules, -default => &{ shift(@$modules) }
if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
if ( $mod =~ m/^-(\w+)$/ ) {
my $option = lc($1);
$default = $arg if ( $option eq 'default' );
$conflict = $arg if ( $option eq 'conflict' );
@tests = @{$arg} if ( $option eq 'tests' );
@skiptests = @{$arg} if ( $option eq 'skiptests' );
next;
}
printf( "- %-${maxlen}s ...", $mod );
if ( $arg and $arg =~ /^\D/ ) {
unshift @$modules, $arg;
$arg = 0;
}
# XXX: check for conflicts and uninstalls(!) them.
if (
defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
push @required, $mod => $arg;
}
}
next unless @required;
my $mandatory = ( $feature eq '-core' or $core_all );
inc/Module/AutoInstall.pm view on Meta::CPAN
qq{==> Auto-install the }
. ( @required / 2 )
. ( $mandatory ? ' mandatory' : ' optional' )
. qq{ module(s) from CPAN?},
$default ? 'y' : 'n',
) =~ /^[Yy]/
)
)
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
elsif ( !$SkipInstall
and $default
and $mandatory
and
_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
=~ /^[Nn]/ )
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
$DisabledTests{$_} = 1 for map { glob($_) } @tests;
}
}
$UnderCPAN = _check_lock(); # check for $UnderCPAN
if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
require Config;
print
"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
inc/Module/AutoInstall.pm view on Meta::CPAN
if $UnderCPAN or $TestOnly;
if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
require ExtUtils::Manifest;
my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
$args{EXE_FILES} =
[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
}
$args{test}{TESTS} ||= 't/*.t';
$args{test}{TESTS} = join( ' ',
grep { !exists( $DisabledTests{$_} ) }
map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
my $missing = join( ',', @Missing );
my $config =
join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
$PostambleActions = (
$missing
? "\$(PERL) $0 --config=$config --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
inc/Module/Install/Makefile.pm view on Meta::CPAN
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
inc/Module/Install/Makefile.pm view on Meta::CPAN
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
require File::Find;
%test_dir = ();
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
$args->{VERSION} = $self->version || $self->determine_VERSION($args);
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ($] >= 5.005) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
my $makefile = do { local $/; <MAKEFILE> };
close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
inc/Module/Install/Metadata.pm view on Meta::CPAN
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my @scalar_keys = qw{
name module_name abstract author version license
distribution_type perl_version tests installdirs
};
my @tuple_keys = qw{
build_requires requires recommends bundles
};
sub Meta { shift }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
inc/Module/Install/Metadata.pm view on Meta::CPAN
push @{ $self->{values}{$key} }, @rv;
@rv;
};
}
# configure_requires is currently a null-op
sub configure_requires { 1 }
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
if( $self->{Have_Plan} ) {
$self->croak("You tried to plan twice");
}
if( $cmd eq 'no_plan' ) {
$self->no_plan;
}
elsif( $cmd eq 'skip_all' ) {
return $self->skip_all($arg);
}
elsif( $cmd eq 'tests' ) {
if( $arg ) {
local $Level = $Level + 1;
return $self->expected_tests($arg);
}
elsif( !defined $arg ) {
$self->croak("Got an undefined number of tests");
}
elsif( !$arg ) {
$self->croak("You said to run 0 tests");
}
}
else {
my @args = grep { defined } ($cmd, $arg);
$self->croak("plan() doesn't understand @args");
}
return 1;
}
#line 290
sub expected_tests {
my $self = shift;
my($max) = @_;
if( @_ ) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/ and $max > 0;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $self->{Expected_Tests};
}
inc/Test/Builder.pm view on Meta::CPAN
$self->{Skip_All} = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
#line 382
sub ok {
my($self, $test, $name) = @_;
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
$self->_plan_check;
lock $self->{Curr_Test};
$self->{Curr_Test}++;
# In case $name is a string overloaded object, force it to stringify.
$self->_unoverload_str(\$name);
$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
my($pack, $file, $line) = $self->caller;
my $todo = $self->todo($pack);
$self->_unoverload_str(\$todo);
my $out;
my $result = &share({});
unless( $test ) {
$out .= "not ";
@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
}
else {
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
}
$out .= "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
if( defined $name ) {
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
$out .= " - $name";
$result->{name} = $name;
}
inc/Test/Builder.pm view on Meta::CPAN
else {
$result->{reason} = '';
$result->{type} = '';
}
$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
$out .= "\n";
$self->_print($out);
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
if( defined $name ) {
$self->diag(qq[ $msg test '$name'\n]);
$self->diag(qq[ at $file line $line.\n]);
}
else {
$self->diag(qq[ $msg test at $file line $line.\n]);
}
}
return $test ? 1 : 0;
}
sub _unoverload {
my $self = shift;
my $type = shift;
$self->_try(sub { require overload } ) || return;
foreach my $thing (@_) {
inc/Test/Builder.pm view on Meta::CPAN
#line 530
sub is_eq {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_str(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, 'eq', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'eq', $expect, $name);
}
sub is_num {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_num(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, '==', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '==', $expect, $name);
}
sub _is_diag {
my($self, $got, $type, $expect) = @_;
foreach my $val (\$got, \$expect) {
if( defined $$val ) {
inc/Test/Builder.pm view on Meta::CPAN
}
#line 608
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'ne', $dont_expect, $name);
}
sub isnt_num {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, '!=', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '!=', $dont_expect, $name);
}
#line 660
sub like {
my($self, $this, $regex, $name) = @_;
inc/Test/Builder.pm view on Meta::CPAN
my($self, $got, $type, $expect, $name) = @_;
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
: '_unoverload_str';
$self->$unoverload(\$got, \$expect);
my $test;
{
local($@,$!,$SIG{__DIE__}); # isolate eval
my $code = $self->_caller_context;
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
}
local $Level = $Level + 1;
my $ok = $self->ok($test, $name);
unless( $ok ) {
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag($got, $type, $expect);
}
else {
$self->_cmp_diag($got, $type, $expect);
}
}
return $ok;
inc/Test/Builder.pm view on Meta::CPAN
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless (defined $usable_regex) {
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
my $test;
my $code = $self->_caller_context;
local($@, $!, $SIG{__DIE__}); # isolate eval
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
$test = !$test if $cmp eq '!~';
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
DIAGNOSTIC
inc/Test/Builder.pm view on Meta::CPAN
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
#line 1000
sub _try {
my($self, $code) = @_;
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
my $return = eval { $code->() };
return wantarray ? ($return, $@) : $return;
}
#line 1022
sub is_fh {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
return 0;
}
#line 1225
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
my $msg = join '', @msgs;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
$msg =~ s/\n(.)/\n# $1/sg;
inc/Test/Builder.pm view on Meta::CPAN
my $self = shift;
my($file_or_fh) = shift;
my $fh;
if( $self->is_fh($file_or_fh) ) {
$fh = $file_or_fh;
}
else {
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
$self->croak("Can't open test output log $file_or_fh: $!");
_autoflush($fh);
}
return $fh;
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
sub _dup_stdhandles {
my $self = shift;
$self->_open_testhandles;
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
_autoflush(\*TESTERR);
_autoflush(\*STDERR);
$self->output(\*TESTOUT);
$self->failure_output(\*TESTERR);
$self->todo_output(\*TESTOUT);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
return if $Opened_Testhandles;
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
$Opened_Testhandles = 1;
}
#line 1396
sub _message_at_caller {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
sub croak {
my $self = shift;
die $self->_message_at_caller(@_);
}
sub _plan_check {
my $self = shift;
unless( $self->{Have_Plan} ) {
local $Level = $Level + 2;
$self->croak("You tried to run a test without a plan");
}
}
#line 1444
sub current_test {
my($self, $num) = @_;
lock($self->{Curr_Test});
if( defined $num ) {
unless( $self->{Have_Plan} ) {
$self->croak("Can't change the current test number without a plan!");
}
$self->{Curr_Test} = $num;
# If the test counter is being pushed forward fill in the details.
my $test_results = $self->{Test_Results};
if( $num > @$test_results ) {
my $start = @$test_results ? @$test_results : 0;
for ($start..$num-1) {
$test_results->[$_] = &share({
'ok' => 1,
actual_ok => undef,
reason => 'incrementing test number',
type => 'unknown',
name => undef
});
}
}
# If backward, wipe history. Its their funeral.
elsif( $num < @$test_results ) {
$#{$test_results} = $num - 1;
}
}
return $self->{Curr_Test};
}
#line 1489
sub summary {
my($self) = shift;
inc/Test/Builder.pm view on Meta::CPAN
}
#line 1602
#line 1616
#'#
sub _sanity_check {
my $self = shift;
$self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
$self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
'Somehow your tests ran without a plan!');
$self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
'Somehow you got a different number of results than tests ran!');
}
#line 1637
sub _whoa {
my($self, $check, $desc) = @_;
if( $check ) {
local $Level = $Level + 1;
$self->croak(<<"WHOA");
WHOA! $desc
inc/Test/Builder.pm view on Meta::CPAN
if( ($self->{Original_Pid} != $$) or
(!$self->{Have_Plan} && !$self->{Test_Died}) or
$self->{Bailed_Out}
)
{
_my_exit($?);
return;
}
# Figure out if we passed or failed and print helpful messages.
my $test_results = $self->{Test_Results};
if( @$test_results ) {
# The plan? We have no plan.
if( $self->{No_Plan} ) {
$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
$self->{Expected_Tests} = $self->{Curr_Test};
}
# Auto-extended arrays and elements which aren't explicitly
# filled in with a shared reference will puke under 5.8.0
# ithreads. So we have to fill them in by hand. :(
my $empty_result = &share({});
for my $idx ( 0..$self->{Expected_Tests}-1 ) {
$test_results->[$idx] = $empty_result
unless defined $test_results->[$idx];
}
my $num_failed = grep !$_->{'ok'},
@{$test_results}[0..$self->{Curr_Test}-1];
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
if( $num_extra < 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
FAIL
}
elsif( $num_extra > 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
FAIL
}
if ( $num_failed ) {
my $num_tests = $self->{Curr_Test};
my $s = $num_failed == 1 ? '' : 's';
my $qualifier = $num_extra == 0 ? '' : ' run';
$self->diag(<<"FAIL");
Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
}
if( $self->{Test_Died} ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
_my_exit( 255 ) && return;
}
my $exit_code;
if( $num_failed ) {
$exit_code = $num_failed <= 254 ? $num_failed : 254;
}
elsif( $num_extra != 0 ) {
inc/Test/Builder.pm view on Meta::CPAN
$exit_code = 0;
}
_my_exit( $exit_code ) && return;
}
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
elsif ( $self->{Test_Died} ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
_my_exit( 255 ) && return;
}
else {
$self->diag("No tests run!\n");
_my_exit( 255 ) && return;
}
}
END {
$Test->_ending if defined $Test and !$Test->no_ending;
}
#line 1847
inc/Test/Builder/Module.pm view on Meta::CPAN
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
};
#line 82
sub import {
my($class) = shift;
my $test = $class->builder;
my $caller = caller;
$test->exported_to($caller);
$class->import_extra(\@_);
my(@imports) = $class->_strip_imports(\@_);
$test->plan(@_);
$class->$_export_to_level(1, $class, @imports);
}
sub _strip_imports {
my $class = shift;
my $list = shift;
my @imports = ();
inc/Test/More.pm view on Meta::CPAN
$idx++;
}
@$list = @other;
}
#line 257
sub ok ($;$) {
my($test, $name) = @_;
my $tb = Test::More->builder;
$tb->ok($test, $name);
}
#line 324
sub is ($$;$) {
my $tb = Test::More->builder;
$tb->is_eq(@_);
}
inc/Test/More.pm view on Meta::CPAN
#line 994
#'#
sub skip {
my($why, $how_many) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
if( defined $how_many and $how_many =~ /\D/ ) {
_carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
$how_many = 1;
}
for( 1..$how_many ) {
$tb->skip($why);
}
local $^W = 0;
last SKIP;
}
#line 1081
sub todo_skip {
my($why, $how_many) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
$tb->todo_skip($why);
}
local $^W = 0;
last TODO;
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
package AI::MaxEntropy::Util;
use Exporter;
our $VERSION = '0.20';
our @ISA = qw/Exporter/;
our @EXPORT_OK =
qw/traverse_partially map_partially train_and_test precision recall/;
our %EXPORT_TAGS =
(all => [@EXPORT_OK]);
sub traverse_partially(&$$;$) {
my ($code, $samples, $pattern, $t) = @_;
$t ||= 'x';
my ($p, $n) = (length($pattern), scalar(@$samples));
for my $i (grep { substr($pattern, $_, 1) eq $t } (0 .. $p - 1)) {
for (int($n * $i / $p) .. int($n * ($i + 1) / $p) - 1) {
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
}
}
sub map_partially(&$$;$) {
my ($code, $samples, $pattern, $t) = @_;
my @r;
traverse_partially { push @r, $code->($_) } $samples, $pattern, $t;
return \@r;
}
sub train_and_test {
my ($me, $samples, $pattern) = @_;
traverse_partially { $me->see(@$_) } $samples, $pattern, 'x';
my $m = $me->learn;
my $r = map_partially { [$_ => $m->predict($_->[0])] }
$samples, $pattern, 'o';
return ($r, $m);
}
sub precision {
my $r = shift;
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
use AI::MaxEntropy::Util qw/:all/;
my $me = AI::MaxEntropy->new;
my $samples = [
[['a', 'b', 'c'] => 'x'],
[['e', 'f'] => 'y' => 1.5],
...
];
my ($result, $model) = train_and_test($me, $samples, 'xxxo');
print precision($result)."\n";
print recall($result, 'x')."\n";
=head1 DESCRIPTION
This module makes doing experiments with Maximum Entropy learner easier.
Generally, an experiment involves a training set and a testing set
(sometimes also a parameter adjusting set). The learner is trained with
samples in the training set and tested with samples in the testing set.
Usually, 2 measures of performance are concerned.
One is precision, indicating the percentage of samples which are correctly
predicted in the testing set. The other one is recall, indicating the
precision of samples with a certain label.
=head1 FUNCTIONS
=head2 train_and_test
This function automated the process of training and testing.
my $me = AI::MaxEntropy->new;
my $sample = [
[ ['a', 'b'] => 'x' => 1.5 ],
...
];
my ($result, $model) = train_and_test($me, $sample, 'xxxo');
First, the whole samples set will be divided into a training set and a
testing set according to the specified pattern. A pattern is a string,
in which each character stands for a part of the samples set.
If the character is C<'x'>, the corresponding part is used for training.
If the character is C<'o'>, the corresponding part is used for testing.
Otherwise, the corresponding part is simply ignored.
For example, the pattern 'xxxo' means the first three forth of the samples
set are used for training while the last one forth is used for testing.
The function returns two values. The first one is an array ref describe
the result of testing, in which each element follows a structure like
C<[sample =E<gt> result]>. The second one is the model learnt from the
training set, which is an L<AI::MaxEntropy::Model> object.
=head2 traverse_partially
This function is the core implementation of L</train_and_test>. It traverse
through some of the elements in an array according to a pattern,
and does some specified actions with each of these elements.
my $arr = [1, 2, 3, 4, 5];
# print out the first two firth of the array
traverse_partially { print } $arr, 'xx---';
# do the same thing, using custom significant character 'o'
traverse_partially { print } $arr, 'oo---' => 'o';
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
to the code snippet's return value.
my $arr = [1, 2, 3, 4, 5];
# increase the last one third of the elements by 1
$arr = map_partially { $_ + 1 } $arr, '--x';
=head2 precision
Calculates the precision based on the result returned by
L</train_and_test>.
...
my ($result, $model) = train_and_test(...);
print precision($result)."\n";
Note that the weights of samples are taken into consideration.
=head2 recall
Calculates the recall of a certain label based on the result returned by
L</train_and_test>.
...
my ($result, $model) = train_and_test(...);
print recall($result, 'label')."\n";
Note that the weights of samples are taken into consideration.
=head1 SEE ALSO
L<AI::MaxEntropy>, L<AI::MaxEntropy::Model>
=head1 AUTHOR
--nochanges don't suggest changes
--nofilter don't filter input files
--list-provided list provided API
--list-unsupported list unsupported API
--api-info=name show Perl API portability information
=head1 COMPATIBILITY
This version of F<ppport.h> is designed to support operation with Perl
installations back to 5.003, and has been tested up to 5.9.3.
=head1 OPTIONS
=head2 --help
Display a brief usage summary.
=head2 --patch=I<file>
If this option is given, a single patch file will be created if
The result will usually be a list of patches suggesting changes
that should at least be acceptable, if not necessarily the most
efficient solution, or a fix for all possible problems.
If you know that your XS module uses features only available in
newer Perl releases, if you're aware that it uses C++ comments,
and if you want all suggestions as a single patch file, you could
use something like this:
perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
If you only want your code to be scanned without any suggestions
for changes, use:
perl ppport.h --nochanges
You can specify a different C<diff> program or options, using
the C<--diff> option:
perl ppport.h --diff='diff -C 10'
to display information for all known API elements.
=head1 BUGS
If this version of F<ppport.h> is causing failure during
the compilation of this module, please check if newer versions
of either this module or C<Devel::PPPort> are available on CPAN
before sending a bug report.
If F<ppport.h> was generated using the latest version of
C<Devel::PPPort> and is causing failure of this module, please
file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
Please include the following information:
=over 4
=item 1.
The complete output from running "perl -V"
=item 4.
A full log of the build that failed.
=item 5.
Any other information that you think could be relevant.
=back
For the latest version of this code, please get the C<Devel::PPPort>
module from CPAN.
=head1 COPYRIGHT
Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz.
Version 2.x, Copyright (C) 2001, Paul Marquess.
Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
if (s == send)
return 0;
/* next must be digit or the radix separator or beginning of infinity */
if (isDIGIT(*s)) {
/* UVs are at least 32 bits, so the first 9 decimal digits cannot
overflow. */
UV value = *s - '0';
/* This construction seems to be more optimiser friendly.
(without it gcc does the isDIGIT test and the *s - '0' separately)
With it gcc on arm is managing 6 instructions (6 cycles) per digit.
In theory the optimiser could deduce how far to unroll the loop
before checking for overflow. */
if (++s < send) {
int digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
t/01-samples.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 10;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
###
t/01-samples.t view on Meta::CPAN
[
[1, 1, 1, 0],
[1, 0, 0, 1]
],
[],
-1
],
$__;
###
NAME 'Yet another test on af_num and f_freq';
$me->forget_all;
$me->see(['a', 'b'] => 'x');
$me->see(['c', 'd'] => 'x');
$me->see(['a', 'c'] => 'y');
$me->see(['a', 'd'] => 'x');
is_deeply
[
$me->{af_num},
$me->{f_freq},
$me->{f_map},
t/02-learn_by_lbfgs.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 5;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
my $me = AI::MaxEntropy->new(smoother => {});
t/03-learn_by_gis.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 3;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
my ($lambda, $d_lambda, $p1_f, $n);
t/04-model.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 5;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load AI::MaxEntropy';
BEGIN { use_ok 'AI::MaxEntropy' }
###
t/04-model.t view on Meta::CPAN
'banana',
'banana',
'apple',
'banana',
'banana'
],
$__;
###
NAME 'Model writing and loading';
$model->save('test_model');
my $model1 = AI::MaxEntropy::Model->new('test_model');
unlink 'test_model';
is_deeply $model, $model1,
$__;
t/05-util.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 8;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy::Util', qw(:all) }
t/05-util.t view on Meta::CPAN
$__;
###
NAME 'map_partially o-o => o';
$a = [1, 2, 3, 4, 5, 6];
$b = map_partially { $_ + 1 } $a, 'o-o' => 'o';
is_deeply $b, [2, 3, 6, 7],
$__;
###
NAME 'train_and_test xxo';
require AI::MaxEntropy;
my ($me, $samples, $result, $model);
$me = AI::MaxEntropy->new;
$samples = [
[['a', 'b', 'c'] => 'x'],
[['e', 'f'] => 'z'],
[['e'] => 'z']
];
($result, $model) = train_and_test($me, $samples, 'xxo');
is_deeply
$result,
[
[[['e'] => 'z'] => 'z']
],
$__;
###
NAME 'train_and_test xxxxo';
$me->forget_all;
$samples = [
[['a', 'b'] => 'x'],
[['c', 'd'] => 'y'],
[['i', 'j'] => 'z'],
[['p', 'q'] => 'xx'],
[['a'] => 'x'],
[['c'] => 'x' => 2]
];
($result, $model) = train_and_test($me, $samples, 'xxxxo');
is_deeply
$result,
[
[[['a'] => 'x'] => 'x'],
[[['c'] => 'x' => 2] => 'y']
],
$__;
###
NAME 'precision';
use strict;
use warnings;
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok();
( run in 0.342 second using v1.01-cache-2.11-cpan-3cd7ad12f66 )