File Coverage

blib/lib/Algorithm/LBFGS.pm

Criterion	Covered	Total	%
statement	31	34	91.1
branch	4	6	66.6
condition			n/a
subroutine	8	10	80.0
pod	6	6	100.0
total	49	56	87.5

package Algorithm::LBFGS;

use strict;
use warnings;

use XSLoader;

our $VERSION = '0.16';
XSLoader::load('Algorithm::LBFGS', $VERSION);

# constructor
sub new {
    my $class = shift;
    my %param = @_;
    my $self = bless { param => create_lbfgs_param() }, $class;
    $self->set_param(%param);
    return $self;
}

# destructor
sub DESTROY {
    my $self = shift;
    destroy_lbfgs_param($self->{param});
}

# set parameters
sub set_param {
    my $self = shift;
    my %param = @_;
    set_lbfgs_param($self->{param}, $_, $param{$_}) for keys %param;
}

# get parameters
sub get_param {
    my $self = shift;
    my $name = shift;
    return set_lbfgs_param($self->{param}, $name, undef);
}

# verbose monitor
my $verbose_monitor = sub {
    my ($x, $g, $fx, $xnorm, $gnorm, $step, $k, $ls, $user_data) = @_;
    ($fx, $xnorm, $gnorm, $step) =
        map { sprintf("%g", $_) } ($fx, $xnorm, $gnorm, $step);
    my $hr = "=" x 79;
    my $s = ":";
    print <
Iteration $k
$hr
  f(x)             $s $fx
  || x ||          $s $xnorm
  || grad f(x) ||  $s $gnorm
  line search step $s $step
  evaluations num  $s $ls

MSG
    return 0;
};

# logging monitor
my $logging_monitor = sub {
    my ($x, $g, $fx, $xnorm, $gnorm, $step, $k, $ls, $user_data) = @_;
    push @$user_data, {
        x => $x, g => $g, fx => $fx, xnorm => $xnorm, gnorm => $gnorm,
	step => $step, k => $k, ls => $ls, user_data => $user_data
    };
    return 0;
};

# do optimization
sub fmin {
    my $self = shift;
    my ($lbfgs_eval, $x0, $lbfgs_prgr, $user_data) = @_;
    if (defined($lbfgs_prgr)) {
        $lbfgs_prgr = $verbose_monitor if ($lbfgs_prgr eq 'verbose');
        $lbfgs_prgr = $logging_monitor if ($lbfgs_prgr eq 'logging');
    }
    my $instance =
        create_lbfgs_instance($lbfgs_eval, $lbfgs_prgr, $user_data);
    $self->{status} = status_2pv(do_lbfgs($self->{param}, $instance, $x0));
    destroy_lbfgs_instance($instance);
    return $x0;
}

# query status
sub get_status {
    my $self = shift;
    return $self->{status};
}

sub status_ok { return get_status(@_) == 0; }

1;

__END__