AI-MaxEntropy
view release on metacpan or search on metacpan
AI-MaxEntropy.xs view on Meta::CPAN
/* Macros for debugging */
/* uncomment the line below to enable tracing and timing */
/*#define __ENABLE_TRACING__*/
#ifdef __ENABLE_TRACING__
#include "time.h"
#define TRACE(msg) \
printf(_fn); printf(": "); printf(msg); \
printf(": %0.10f s\n", 1.0 * (clock() - _t) / CLOCKS_PER_SEC); \
fflush(stdout); _t = clock()
#define dTRACE(fn) clock_t _t = clock(); char* _fn = fn
#else
#define TRACE(msg)
#define dTRACE
#endif
$me->see(['big', 'rough'] => 'pomelo');
# ...
# and, let it learn
my $model = $me->learn;
# then, we can make predictions on unseen data
# ask what a red thing is most likely to be
print $model->predict(['red'])."\n";
# the answer is apple, because all red things the learner have ever seen
# are apples
# ask what a smooth thing is most likely to be
print $model->predict(['smooth'])."\n";
# the answer is banana, because the learner have seen more smooth bananas
# (weighted 3) than smooth apples (weighted 2)
# ask what a red, long thing is most likely to be
print $model->predict(['red', 'long'])."\n";
# the answer is banana, because the learner have seen more long bananas
# (weighted 3) than red apples (weighted 2)
# print out scores of all possible answers to the feature round and red
for ($model->all_labels) {
my $s = $model->score(['round', 'red'] => $_);
print "$_: $s\n";
}
# save the model
$model->save('model_file');
# load the model
$model->load('model_file');
CONCEPTS
What is a Maximum Entropy model?
learn
Learn a model from all the samples that the learner have seen so far,
returns an AI::MaxEntropy::Model object, which can be used to make
prediction on unlabeled samples.
...
my $model = $me->learn;
print $model->predict(['x1', 'x2', ...]);
PROPERTIES
algorithm
This property enables client program to choose different algorithms for
learning the ME model and set their parameters.
There are mainly 3 algorithm for learning ME models, they are GIS, IIS
and L-BFGS. This module implements 2 of them, namely, L-BFGS and GIS.
L-BFGS provides full functionality, while GIS runs faster, but only
applicable on limited scenarios.
progress_cb(i, lambda, d_lambda, lambda_norm, d_lambda_norm)
"i" is the number of the iterations, "lambda" is an array ref containing
the current lambda vector, "d_lambda" is an array ref containing the
delta of the lambda vector in current iteration, "lambda_norm" and
"d_lambda_norm" are Euclid norms of "lambda" and "d_lambda"
respectively.
For both L-BFGS and GIS, the client program can also pass a string
'verbose' to "progress_cb" to use a default progress callback which
simply print out the progress on the screen.
"progress_cb" can also be omitted if the client program do not want to
trace the progress.
parameters
The rest entries are parameters for the specified algorithm. Each
parameter will be assigned with its default value when it is not given
explicitly.
For L-BFGS, the parameters will be directly passed to Algorithm::LBFGS
inc/Module/AutoInstall.pm view on Meta::CPAN
}
}
# overrides MakeMaker's prompt() to automatically accept the default choice
sub _prompt {
goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
my ( $prompt, $default ) = @_;
my $y = ( $default =~ /^[Yy]/ );
print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
print "$default\n";
return $default;
}
# the workhorse
sub import {
my $class = shift;
my @args = @_ or return;
my $core_all;
print "*** $class version " . $class->VERSION . "\n";
print "*** Checking for Perl dependencies...\n";
my $cwd = Cwd::cwd();
$Config = [];
my $maxlen = length(
(
sort { length($b) <=> length($a) }
grep { /^[^\-]/ }
map {
inc/Module/AutoInstall.pm view on Meta::CPAN
# sets CPAN configuration options
$Config = $modules if $option eq 'config';
# promote every features to core status
$core_all = ( $modules =~ /^all$/i ) and next
if $option eq 'core';
next unless $option eq 'core';
}
print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
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 );
if (
!$SkipInstall
inc/Module/AutoInstall.pm view on Meta::CPAN
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";
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
if eval '$>';
}
print "*** $class configuration finished.\n";
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing;
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
print <<'END_MESSAGE';
*** Since we're running under CPANPLUS, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
_load_cpan();
# Find the CPAN lock-file
inc/Module/AutoInstall.pm view on Meta::CPAN
return unless -f $lock;
# Check the lock
local *LOCK;
return unless open(LOCK, $lock);
if (
( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
) {
print <<'END_MESSAGE';
*** Since we're running under CPAN, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
close LOCK;
return;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
push @installed, $pkg;
}
else {
push @modules, $pkg, $ver;
}
}
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
print "*** Installing dependencies...\n";
return unless _connected_to('cpan.org');
my %args = @config;
my %failed;
local *FAILED;
if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
while (<FAILED>) { chomp; $failed{$_}++ }
close FAILED;
inc/Module/AutoInstall.pm view on Meta::CPAN
}
@modules = @newmod;
}
if ( _has_cpanplus() ) {
_install_cpanplus( \@modules, \@config );
} else {
_install_cpan( \@modules, \@config );
}
print "*** $class installation finished.\n";
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
if ( defined( _version_check( _load($pkg), $ver ) ) ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
print FAILED "$pkg\n";
}
}
close FAILED if $args{do_once};
return @installed;
}
sub _install_cpanplus {
my @modules = @{ +shift };
inc/Module/AutoInstall.pm view on Meta::CPAN
$conf->set_conf( prereqs => 1 );
while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
$conf->set_conf( $key, $val );
}
my $modtree = $cp->module_tree;
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
print "*** Installing $pkg...\n";
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
my $success;
my $obj = $modtree->{$pkg};
if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = $cp->install( modules => [ $obj->{module} ] );
if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
print "*** $pkg successfully installed.\n";
$success = 1;
} else {
print "*** $pkg installation cancelled.\n";
$success = 0;
}
$installed += $success;
} else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
( $args{$opt} = $arg, next )
if $opt =~ /^force$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
print "*** Installing $pkg...\n";
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
inc/Module/AutoInstall.pm view on Meta::CPAN
my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
: CPAN::Shell->install($pkg);
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
if $CPAN::META;
};
if ( $rv eq 'YES' ) {
print "*** $pkg successfully installed.\n";
$success = 1;
}
else {
print "*** $pkg installation failed.\n";
$success = 0;
}
$installed += $success;
}
else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
'y' ) =~ /^[Nn]/
)
{
die "*** Please install $class $ver manually.\n";
}
print << ".";
*** Trying to fetch it from CPAN...
.
# install ourselves
_load($class) and return $class->import(@_)
if $class->install( [], $class, $ver );
print << '.'; exit 1;
*** Cannot bootstrap myself. :-( Installation terminated.
.
}
# check if we're connected to some host, using inet_aton
sub _connected_to {
my $site = shift;
return (
inc/Module/AutoInstall.pm view on Meta::CPAN
);
}
# check if a directory is writable; may create it on demand
sub _can_write {
my $path = shift;
mkdir( $path, 0755 ) unless -e $path;
return 1 if -w $path;
print << ".";
*** You are not allowed to write to the directory '$path';
the installation may fail due to insufficient permissions.
.
if (
eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
qq(
==> Should we try to re-execute the autoinstall process with 'sudo'?),
((-t STDIN) ? 'y' : 'n')
) =~ /^[Yy]/
)
{
# try to bootstrap ourselves from sudo
print << ".";
*** Trying to re-execute the autoinstall process with 'sudo'...
.
my $missing = join( ',', @Missing );
my $config = join( ',',
UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
return
unless system( 'sudo', $^X, $0, "--config=$config",
"--installdeps=$missing" );
print << ".";
*** The 'sudo' command exited with error! Resuming...
.
}
return _prompt(
qq(
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
return %args;
}
# a wrapper to ExtUtils::MakeMaker::WriteMakefile
sub Write {
require Carp;
Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
if ($CheckOnly) {
print << ".";
*** Makefile not written in check-only mode.
.
return;
}
my %args = _make_args(@_);
no strict 'refs';
$PostambleUsed = 0;
local *MY::postamble = \&postamble unless defined &MY::postamble;
ExtUtils::MakeMaker::WriteMakefile(%args);
print << "." unless $PostambleUsed;
*** WARNING: Makefile written with customized MY::postamble() without
including contents from Module::AutoInstall::postamble() --
auto installation features disabled. Please contact the author.
.
return 1;
}
sub postamble {
$PostambleUsed = 1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
inc/Test/Builder.pm view on Meta::CPAN
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};
}
#line 315
sub no_plan {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
sub skip_all {
my($self, $reason) = @_;
my $out = "1..0";
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$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.
inc/Test/Builder.pm view on Meta::CPAN
$result->{type} = 'todo';
}
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]);
}
}
inc/Test/Builder.pm view on Meta::CPAN
else {
# force numeric context
$self->_unoverload_num($val);
}
}
else {
$$val = 'undef';
}
}
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
#line 608
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
inc/Test/Builder.pm view on Meta::CPAN
}
}
return $ok;
}
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub _caller_context {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
return $code;
}
#line 771
sub BAIL_OUT {
my($self, $reason) = @_;
$self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
#line 784
*BAILOUT = \&BAIL_OUT;
#line 796
inc/Test/Builder.pm view on Meta::CPAN
type => 'skip',
reason => $why,
});
my $out = "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # skip";
$out .= " $why" if length $why;
$out .= "\n";
$self->_print($out);
return 1;
}
#line 838
sub todo_skip {
my($self, $why) = @_;
$why ||= '';
inc/Test/Builder.pm view on Meta::CPAN
actual_ok => 0,
name => '',
type => 'todo_skip',
reason => $why,
});
my $out = "not ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$self->_print($out);
return 1;
}
#line 916
sub maybe_regex {
my ($self, $regex) = @_;
inc/Test/Builder.pm view on Meta::CPAN
$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
}
return $ok;
}
inc/Test/Builder.pm view on Meta::CPAN
#line 1188
sub diag {
my($self, @msgs) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
# Escape each line with a #.
$msg =~ s/^/# /gm;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
local $Level = $Level + 1;
$self->_print_diag($msg);
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;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
print $fh $msg;
}
#line 1259
sub _print_diag {
my $self = shift;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
print $fh @_;
}
#line 1296
sub output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Out_FH} = $self->_new_fh($fh);
}
inc/Test/Builder.pm view on Meta::CPAN
$| = 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);
}
inc/Test/Builder.pm view on Meta::CPAN
# Don't do an ending if we bailed out.
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];
inc/Test/More.pm view on Meta::CPAN
my $tb = Test::More->builder;
unless( @_ == 2 or @_ == 3 ) {
my $msg = <<WARNING;
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead
of a reference to it
WARNING
chop $msg; # clip off newline so carp() will put in line/file
_carp sprintf $msg, scalar @_;
return $tb->ok(0);
}
my($got, $expected, $name) = @_;
$tb->_unoverload_str(\$expected, \$got);
my $ok;
if( !ref $got and !ref $expected ) { # neither is a reference
inc/Test/Number/Delta.pm view on Meta::CPAN
else {
$ok = 0;
$diag = "Got an array of length " . scalar(@$p) .
", but expected an array of length " . scalar(@$q);
}
}
else {
$ok = abs($p - $q) < $epsilon;
if ( ! $ok ) {
my ($ep, $dp) = _ep_dp( $epsilon );
$diag = sprintf("%.${dp}f and %.${dp}f are not equal" .
" to within %.${ep}f", $p, $q, $epsilon
);
}
}
return ( $ok, $diag, scalar(@indices) ? @indices : () );
}
sub _ep_dp {
my $epsilon = shift;
my ($exp) = sprintf("%e",$epsilon) =~ m/e(.+)/;
my $ep = $exp < 0 ? -$exp : 1;
my $dp = $ep + 1;
return ($ep, $dp);
}
#line 200
#--------------------------------------------------------------------------#
# delta_within()
#--------------------------------------------------------------------------#
inc/Test/Number/Delta.pm view on Meta::CPAN
#line 292
sub delta_not_within($$$;$) {
my ($p, $q, $epsilon, $name) = @_;
croak "Value of epsilon to delta_not_within must be non-zero"
if $epsilon == 0;
$epsilon = abs($epsilon);
my ($ok, undef, @indices) = _check( $p, $q, $epsilon, $name );
$ok = !$ok;
my ($ep, $dp) = _ep_dp( $epsilon );
my $diag = sprintf("Arguments are equal to within %.${ep}f", $epsilon);
return $Test->ok($ok,$name) || $Test->diag( $diag );
}
#line 315
sub delta_not_ok($$;$) {
my ($p, $q, $name) = @_;
{
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $e = $Relative
lib/AI/MaxEntropy.pm view on Meta::CPAN
if ($type eq 'lbfgs') {
my $o = Algorithm::LBFGS->new(%{$self->{algorithm}});
$o->fmin(\&_neg_log_likelihood, $self->{lambda},
$self->{algorithm}->{progress_cb}, $self);
}
elsif ($type eq 'gis') {
die 'GIS is not applicable'
if $self->{af_num} == -1 or $self->{last_cut} != 0;
my $progress_cb = $self->{algorithm}->{progress_cb};
$progress_cb = sub {
print "$_[0]: |lambda| = $_[3], |d_lambda| = $_[4]\n"; 0;
} if defined($progress_cb) and $progress_cb eq 'verbose';
my $epsilon = $self->{algorithm}->{epsilon} || 1e-3;
$self->{lambda} = $self->_apply_gis($progress_cb, $epsilon);
}
else { die "$type is not a valid algorithm type" }
# finish
$self->_free_cache;
return $self->_create_model;
}
lib/AI/MaxEntropy.pm view on Meta::CPAN
$me->see(['big', 'rough'] => 'pomelo');
# ...
# and, let it learn
my $model = $me->learn;
# then, we can make predictions on unseen data
# ask what a red thing is most likely to be
print $model->predict(['red'])."\n";
# the answer is apple, because all red things the learner have ever seen
# are apples
# ask what a smooth thing is most likely to be
print $model->predict(['smooth'])."\n";
# the answer is banana, because the learner have seen more smooth bananas
# (weighted 3) than smooth apples (weighted 2)
# ask what a red, long thing is most likely to be
print $model->predict(['red', 'long'])."\n";
# the answer is banana, because the learner have seen more long bananas
# (weighted 3) than red apples (weighted 2)
# print out scores of all possible answers to the feature round and red
for ($model->all_labels) {
my $s = $model->score(['round', 'red'] => $_);
print "$_: $s\n";
}
# save the model
$model->save('model_file');
# load the model
$model->load('model_file');
=head1 CONCEPTS
lib/AI/MaxEntropy.pm view on Meta::CPAN
=head2 learn
Learn a model from all the samples that the learner have seen so far,
returns an L<AI::MaxEntropy::Model> object, which can be used to make
prediction on unlabeled samples.
...
my $model = $me->learn;
print $model->predict(['x1', 'x2', ...]);
=head1 PROPERTIES
=head2 algorithm
This property enables client program to choose different algorithms for
learning the ME model and set their parameters.
There are mainly 3 algorithm for learning ME models, they are GIS, IIS and
L-BFGS. This module implements 2 of them, namely, L-BFGS and GIS.
lib/AI/MaxEntropy.pm view on Meta::CPAN
progress_cb(i, lambda, d_lambda, lambda_norm, d_lambda_norm)
C<i> is the number of the iterations, C<lambda> is an array ref containing
the current lambda vector, C<d_lambda> is an array ref containing the
delta of the lambda vector in current iteration, C<lambda_norm> and
C<d_lambda_norm> are Euclid norms of C<lambda> and C<d_lambda> respectively.
For both L-BFGS and GIS, the client program can also pass a string
C<'verbose'> to C<progress_cb> to use a default progress callback
which simply print out the progress on the screen.
C<progress_cb> can also be omitted if the client program
do not want to trace the progress.
=head3 parameters
The rest entries are parameters for the specified algorithm.
Each parameter will be assigned with its default value when it is not
given explicitly.
lib/AI/MaxEntropy/Model.pm view on Meta::CPAN
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
$me->see(['round', 'rough'] => 'orange' => 2);
my $model = $me->learn;
# make prediction on unseen data
# ask what a red round thing is most likely to be
my $y = $model->predict(['round', 'red']);
# the answer apple is expected
# print out scores of all possible labels
for ($model->all_labels) {
my $s = $model->score(['round', 'red'] => $_);
print "$_: $s\n";
}
# save the model to file
$model->save('model_file');
# load the model from file
$model->load('model_file');
=head1 DESCRIPTION
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
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
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
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';
my $samples = [
[['a', 'b'] => 'x'],
[['c', 'd'] => 'y' => 1.5],
...
];
my $me = AI::MaxEntropy->new;
# see the first one third and the last one third samples
traverse_partially { $me->see(@$_) } $samples, 'x-x';
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
# 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
Laye Suen, E<lt>laye@cpan.orgE<gt>
any changes are suggested. This requires a working diff program
to be installed on your system.
=head2 --copy=I<suffix>
If this option is given, a copy of each file will be saved with
the given suffix that contains the suggested changes. This does
not require any external programs.
If neither C<--patch> or C<--copy> are given, the default is to
simply print the diffs for each file. This requires either
C<Text::Diff> or a C<diff> program to be installed.
=head2 --diff=I<program>
Manually set the diff program and options to use. The default
is to use C<Text::Diff>, when installed, and output unified
context diffs.
=head2 --compat-version=I<version>
=head2 --cplusplus
Usually, F<ppport.h> will detect C++ style comments and
replace them with C style comments for portability reasons.
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes.
=head2 --nochanges
Don't suggest any changes. Only give diagnostic output and hints
unless these are also deactivated.
usage() if $opt{help};
if (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
# Never use C comments in this file!!!!!
my $ccs = '/'.'*';
my $cce = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;
do_magic_dump||5.006000|
do_msgrcv|||
do_msgsnd|||
do_oddball|||
do_op_dump||5.006000|
do_open9||5.006000|
do_openn||5.007001|
do_open||5.004000|
do_pipe|||
do_pmop_dump||5.006000|
do_print|||
do_readline|||
do_seek|||
do_semop|||
do_shmio|||
do_spawn_nowait|||
do_spawn|||
do_sprintf|||
do_sv_dump||5.006000|
do_sysseek|||
do_tell|||
do_trans_complex_utf8|||
do_trans_complex|||
do_trans_count_utf8|||
do_trans_count|||
do_trans_simple_utf8|||
do_trans_simple|||
do_trans|||
fold_constants|||
forbid_setid|||
force_ident|||
force_list|||
force_next|||
force_version|||
force_word|||
form_nocontext|||vn
form||5.004000|v
fp_dup|||
fprintf_nocontext|||vn
free_global_struct|||
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
get_av|5.006000||p
get_context||5.006000|n
get_cv|5.006000||p
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
is_uni_digit_lc||5.006000|
is_uni_digit||5.006000|
is_uni_graph_lc||5.006000|
is_uni_graph||5.006000|
is_uni_idfirst_lc||5.006000|
is_uni_idfirst||5.006000|
is_uni_lower_lc||5.006000|
is_uni_lower||5.006000|
is_uni_print_lc||5.006000|
is_uni_print||5.006000|
is_uni_punct_lc||5.006000|
is_uni_punct||5.006000|
is_uni_space_lc||5.006000|
is_uni_space||5.006000|
is_uni_upper_lc||5.006000|
is_uni_upper||5.006000|
is_uni_xdigit_lc||5.006000|
is_uni_xdigit||5.006000|
is_utf8_alnumc||5.006000|
is_utf8_alnum||5.006000|
is_utf8_ascii||5.006000|
is_utf8_char_slow|||
is_utf8_char||5.006000|
is_utf8_cntrl||5.006000|
is_utf8_digit||5.006000|
is_utf8_graph||5.006000|
is_utf8_idcont||5.008000|
is_utf8_idfirst||5.006000|
is_utf8_lower||5.006000|
is_utf8_mark||5.006000|
is_utf8_print||5.006000|
is_utf8_punct||5.006000|
is_utf8_space||5.006000|
is_utf8_string_loclen||5.009003|
is_utf8_string_loc||5.008001|
is_utf8_string||5.006001|
is_utf8_upper||5.006000|
is_utf8_xdigit||5.006000|
isa_lookup|||
items|||n
ix|||n
pidgone|||
pmflag|||
pmop_dump||5.006000|
pmruntime|||
pmtrans|||
pop_scope|||
pregcomp|||
pregexec|||
pregfree|||
prepend_elem|||
printf_nocontext|||vn
ptr_table_clear|||
ptr_table_fetch|||
ptr_table_free|||
ptr_table_new|||
ptr_table_split|||
ptr_table_store|||
push_scope|||
put_byte|||
pv_display||5.006000|
pv_uni_display||5.007003|
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %depends);
my $replace = 0;
my $hint = '';
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}
if (exists $opt{'api-info'}) {
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "$hints{$f}" if exists $hints{$f};
$info++;
}
unless ($info) {
print "No portability information available.\n";
}
$count++;
}
if ($count > 0) {
print "\n";
}
else {
print "Found no API matching '$opt{'api-info'}'.\n";
}
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
my @srcext = qw( xs c h cc cpp );
my $srcext = join '|', @srcext;
if (@ARGV) {
my %seen;
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
sub hint
{
$opt{quiet} and return;
$opt{hints} or return;
my $func = shift;
exists $hints{$func} or return;
$given_hints{$func}++ and return;
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
ENDUSAGE
exit 2;
}
( run in 0.965 second using v1.01-cache-2.11-cpan-de7293f3b23 )