view release on metacpan or  search on metacpan

src/liblinear.xs  view on Meta::CPAN

#include <algorithm>
#include <cerrno>
#include <cstdlib>
#include <cstring>
#include "linear.h"

#define NO_XSLOCKS
#include "EXTERN.h"
#include "XSUB.h"
#include "perl.h"
#include "ppport.h"

namespace {

struct parameter *
alloc_parameter(pTHX_ int num_weights) {
    struct parameter *parameter_;
    Newx(parameter_, 1, struct parameter);
    if (num_weights == 0) {
        parameter_->weight_label = NULL;
        parameter_->weight = NULL;
    } else {
        Newx(parameter_->weight_label, num_weights, int);
        Newx(parameter_->weight, num_weights, double);
    }
    parameter_->init_sol = NULL;
    parameter_->nr_weight = num_weights;
    return parameter_;
}

struct problem *
alloc_problem(pTHX_ int num_training_data) {
    struct problem *problem_;
    Newx(problem_, 1, struct problem);
    Newx(problem_->y, num_training_data, double);
    // Assuming that internal representation of null pointer is zero.
    Newxz(problem_->x, num_training_data, struct feature_node *);
    problem_->l = num_training_data;
    return problem_;
}

void
dummy_puts(const char *) {}

int
find_max_feature_index(pTHX_ AV *features) {
    int num_features = av_len(features) + 1;
    int max_feature_index = 0;
    for (int i = 0; i < num_features; ++i) {
        SV *feature = *av_fetch(features, i, 0);
        if (!(SvROK(feature) && SvTYPE(SvRV(feature)) == SVt_PVHV)) {
            Perl_croak(aTHX_ "Not a HASH reference.");
        }
        HV *feature_hash = (HV *)SvRV(feature);
        hv_iterinit(feature_hash);
        HE *nonzero_element;
        while ((nonzero_element = hv_iternext(feature_hash))) {
            I32 index_length;
            int index = atoi(hv_iterkey(nonzero_element, &index_length));
            if (max_feature_index < index) { max_feature_index = index; }
        }
    }
    return max_feature_index;
}

void
free_parameter(pTHX_ struct parameter *parameter_) {
    Safefree(parameter_->weight_label);
    Safefree(parameter_->weight);
    Safefree(parameter_);
}

void
free_problem(pTHX_ struct problem *problem_) {
    for (int i = 0; i < problem_->l; ++i) {
        struct feature_node *feature_vector = problem_->x[i];
        if (feature_vector) { Safefree(feature_vector); }
    }
    Safefree(problem_->x);
    Safefree(problem_->y);
    Safefree(problem_);
}

bool
has_less_index(const struct feature_node& a, const struct feature_node& b) {
    return a.index < b.index;
}

struct feature_node *
hv2feature(
    pTHX_ HV *feature_hash, int bias_index = 0, double bias = -1.0) {
    bool has_bias = bias >= 0;
    int feature_vector_size =
        hv_iterinit(feature_hash) + (has_bias ? 1 : 0) + 1;
    struct feature_node *feature_vector;
    Newx(feature_vector, feature_vector_size, struct feature_node);
    char *index;
    I32 index_length;
    SV *value;
    struct feature_node *curr = feature_vector;
    while ((value = hv_iternextsv(feature_hash, &index, &index_length))) {
        curr->index = atoi(index);
        curr->value = SvNV(value);
        ++curr;
    }
    if (has_bias) {
        curr->index = bias_index;
        curr->value = bias;
        ++curr;
    }
    // Sentinel. LIBLINEAR doesn't care about its value.
    curr->index = -1;
    // Since LIBLINEAR 2.40, |sparse_operator::sparse_dot|, used in one-class
    // SVM solver (|solve_oneclass_svm|), started to assume that the
    // |feature_node| vector is sorted by |index|.
    std::sort(
        feature_vector,
        // |- 1| for removing sentinel node from the range of sorting.
        feature_vector + feature_vector_size - 1,
        has_less_index);
    return feature_vector;
}

inline bool
is_regression_solver(const struct parameter *parameter_) {
    switch (parameter_->solver_type) {
    case L2R_L2LOSS_SVR:
    case L2R_L2LOSS_SVR_DUAL:
    case L2R_L1LOSS_SVR_DUAL:
        return true;
    default:
        return false;
    }
}

void
validate_parameter(
    pTHX_
    struct problem *problem_,
    struct parameter *parameter_) {
    const char *message = check_parameter(problem_, parameter_);
    if (message) {
        Perl_croak(aTHX_ "Invalid training parameter: %s", message);
    }
}

}  // namespace

MODULE = Algorithm::LibLinear  PACKAGE = Algorithm::LibLinear::Model::Raw  PREFIX = ll_

TYPEMAP: <<'EOT'
TYPEMAP
AV * T_AVREF_REFCOUNT_FIXED

struct model * T_LIBLINEAR_MODEL

struct parameter * T_LIBLINEAR_TRAINING_PARAMETER

struct problem * T_LIBLINEAR_PROBLEM

INPUT