Algorithm-Cluster

 view release on metacpan or  search on metacpan

perl/Cluster.xs  view on Meta::CPAN

int
right (obj)
    SV* obj
    CODE:
    RETVAL = (INT2PTR(Node*,SvIV(SvRV(obj))))->right;
    OUTPUT:
    RETVAL

double
distance (obj)
    SV* obj
    CODE:
    RETVAL = (INT2PTR(Node*,SvIV(SvRV(obj))))->distance;
    OUTPUT:
    RETVAL

void
set_left (obj, left)
    SV* obj
    int left
    PREINIT:
    Node* node;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Node")) {
        croak("set_left should be applied to an Algorithm::Cluster::Node object");
    }
    node = INT2PTR(Node*,SvIV(SvRV(obj)));
    node->left = left;

void
set_right (obj, right)
    SV* obj
    int right
    PREINIT:
    Node* node;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Node")) {
        croak("set_right should be applied to an Algorithm::Cluster::Node object");
    }
    node = INT2PTR(Node*,SvIV(SvRV(obj)));
    node->right = right;

void
set_distance (obj, distance)
    SV* obj
    double distance
    PREINIT:
    Node* node;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Node")) {
        croak("set_distance should be applied to an Algorithm::Cluster::Node object");
    }
    node = INT2PTR(Node*,SvIV(SvRV(obj)));
    node->distance = distance;

void DESTROY (obj)
    SV* obj
    PREINIT:
    I32* temp;
    Node* node;
    PPCODE:
    temp = PL_markstack_ptr++;
    node = INT2PTR(Node*, SvIV(SvRV(obj)));
    free(node);
    if (PL_markstack_ptr != temp) {
        /* truly void, because dXSARGS not invoked */
        PL_markstack_ptr = temp;
        XSRETURN_EMPTY;
        /* return empty stack */
    }  /* must have used dXSARGS; list context implied */
    return;  /* assume stack size is correct */


MODULE = Algorithm::Cluster PACKAGE = Algorithm::Cluster::Tree
PROTOTYPES: ENABLE

SV*
new (class, nodes)
    char* class
    SV* nodes

    PREINIT:
    Tree* tree;
    SV* obj;
    int i;
    int n;
    AV* array;
    int* flag;

    CODE:
    if(!SvROK(nodes) || SvTYPE(SvRV(nodes)) != SVt_PVAV) { 
        croak("Algorithm::Cluster::Tree::new expects an array of nodes\n");
    }
    array = (AV *) SvRV(nodes);
    n = (int) av_len(array) + 1;
    tree = malloc(sizeof(Tree));
    if (tree) {
        tree->n = n;
        tree->nodes = malloc(n*sizeof(Node));
    }
    if (! tree || !tree->nodes) {
        if (tree) free(tree);
        croak("Algorithm::Cluster::Tree::new memory error\n");
    }

    for (i = 0; i < n; i++) {
        Node* node;
        SV* node_ref = *(av_fetch(array, (I32) i, 0)); 
        if (!sv_isa(node_ref, "Algorithm::Cluster::Node")) break;
        node = INT2PTR(Node*,SvIV(SvRV(node_ref)));
        tree->nodes[i].left = node->left;
        tree->nodes[i].right = node->right;
        tree->nodes[i].distance = node->distance;
    }

    if (i < n) {
        /* break encountered */
        free(tree->nodes);
        free(tree);
        croak("Algorithm::Cluster::Tree::new expects an array of nodes\n");
    }

perl/Cluster.xs  view on Meta::CPAN

    Node* node;
    SV* scalar;
    CODE:
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    if (index < 0 || index >= tree->n) {
        croak("Index out of bounds in Algorithm::Cluster::Tree::get\n");
    }
    RETVAL = newSViv(0);
    scalar = newSVrv(RETVAL, "Algorithm::Cluster::Node");
    node = malloc(sizeof(Node));
    if (!node) {
        croak("Memory allocation failure in Algorithm::Cluster::Tree::get\n");
    }
    node->left = tree->nodes[index].left;
    node->right = tree->nodes[index].right;
    node->distance = tree->nodes[index].distance;
    sv_setiv(scalar, PTR2IV(node));
    SvREADONLY_on(scalar);
    OUTPUT:
    RETVAL

void
scale(obj)
    SV* obj
    PREINIT:
    int i;
    int n;
    Tree* tree;
    Node* nodes;
    double maximum;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Tree")) {
        croak("scale can only be applied to an Algorithm::Cluster::Tree object");
    }
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    n = tree->n;
    nodes = tree->nodes;
    maximum = DBL_MIN;
    for (i = 0; i < n; i++) {
        double distance = nodes[i].distance;
        if (distance > maximum) maximum = distance;
    }
    if (maximum!=0.0) {
        for (i = 0; i < n; i++) nodes[i].distance /= maximum;
    }


void
sort(obj, order = NULL)
    SV* obj
    SV* order 

    PREINIT:
    int i;
    int n;
    Tree* tree;
    int* indices;
    double* values = NULL;
    int ok;

    PPCODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Tree")) {
        croak("sort can only be applied to an Algorithm::Cluster::Tree object");
    }
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    if (order) {
        if(!SvROK(order) || SvTYPE(SvRV(order)) != SVt_PVAV) { 
            croak("Algorithm::Cluster::Tree::sort expects an order array\n");
        }
        values = malloc_row_perl2c_dbl(aTHX_ order, &n);
        if (!values) {
            croak("Algorithm::Cluster::Tree::sort memory error\n");
        }
        if (n != tree->n + 1) {
            free(values);
            croak("sort: size of order array is inconsistent with tree size\n");
        }
    }
    else {
        n = tree->n + 1;
    }
    indices = malloc(n*sizeof(int));
    if (!indices) {
        if(values) free(values);
        croak("sort: insufficient memory");
    }
    /* --------------------------------------------------------------- */
    ok = sorttree(tree->n, tree->nodes, values, indices);
    if(values) free(values);
    /* -- Check for errors flagged by the C routine ------------------ */
    if (!ok) {
        free(indices);
        croak("sort: Error in the sorttree routine");
    }
    for(i=0; i<n; i++) XPUSHs(sv_2mortal(newSVnv(indices[i])));
    free(indices);

void
cut(obj, nclusters=0)
    SV* obj
    int nclusters
    PREINIT:
    int ok;
    int i;
    int n;
    Tree* tree;
    int* clusterid;
    PPCODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Tree")) {
        croak("cut can only be applied to an Algorithm::Cluster::Tree object\n");
    }
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    n = tree->n + 1;
    if (nclusters < 0) {
        croak("cut: Requested number of clusters should be positive\n");
    }
    if (nclusters > n) {
        croak("cut: More clusters requested than items available\n");
    }
    if (nclusters == 0) {
        nclusters = n;
    }
    clusterid = malloc(n*sizeof(int));
    if (!clusterid) {
        croak("cut: Insufficient memory\n");
    }
    ok = cuttree(n, tree->nodes, nclusters, clusterid);
    if (!ok) {
        free(clusterid);
        croak("cut: Error in the cuttree routine\n");
    }
    for(i=0; i<n; i++) XPUSHs(sv_2mortal(newSVnv(clusterid[i])));
    free(clusterid);


void DESTROY (obj)
    SV* obj
    PREINIT:
    I32* temp;
    Tree* tree;
    PPCODE:
    temp = PL_markstack_ptr++;
    tree = INT2PTR(Tree*, SvIV(SvRV(obj)));
    free(tree->nodes);
    free(tree);
    if (PL_markstack_ptr != temp) {
        /* truly void, because dXSARGS not invoked */
        PL_markstack_ptr = temp;
        XSRETURN_EMPTY;
        /* return empty stack */
    }  /* must have used dXSARGS; list context implied */
    return;  /* assume stack size is correct */


MODULE = Algorithm::Cluster    PACKAGE = Algorithm::Cluster
PROTOTYPES: ENABLE


SV *
_version()
    CODE:
    RETVAL = newSVpv( CLUSTERVERSION , 0);

    OUTPUT:
    RETVAL



SV *
_mean(input)
    SV * input;

    PREINIT:
    int array_length;
    double * data;  /* one-dimensional array of doubles */

    CODE:
    if(SvTYPE(SvRV(input)) != SVt_PVAV) { 
        XSRETURN_UNDEF;
    }

    data = malloc_row_perl2c_dbl (aTHX_ input, &array_length);
    if (data) {
        RETVAL = newSVnv( mean(array_length, data) );
        free(data);
    } else {
        croak("memory allocation failure in _mean\n");
    }

    OUTPUT:
    RETVAL


SV *
_median(input)
    SV * input;

    PREINIT:
    int array_length;
    double * data;  /* one-dimensional array of doubles */

perl/Cluster.xs  view on Meta::CPAN

        tree->n = n;
        tree->nodes = malloc(n*sizeof(Node));
        if (!tree->nodes) {
            free(tree);
            croak("Memory allocation failure in Algorithm::Cluster::Tree\n");
        }
        sv_setiv(obj, PTR2IV(tree));
        SvREADONLY_on(obj);
        for(i=0; i<n; i++) {
            tree->nodes[i].left = nodes[i].left;
            tree->nodes[i].right = nodes[i].right;
            tree->nodes[i].distance = nodes[i].distance;
        }
        free(nodes);
    }

    /* ------------------------
     * Free what we've malloc'ed 
     */
    if (matrix) {
        free_matrix_int(mask,     nrows);
        free_matrix_dbl(matrix,   nrows);
        free(weight);
    } else {
        free_ragged_matrix_dbl(distancematrix, nelements);
    }

    /* Finished _treecluster() */
    OUTPUT:
    RETVAL


void
_kcluster(nclusters,nrows,ncols,data_ref,mask_ref,weight_ref,transpose,npass,method,dist,initialid_ref)
    int      nclusters;
    int      nrows;
    int      ncols;
    SV *     data_ref;
    SV *     mask_ref;
    SV *     weight_ref;
    int      transpose;
    int      npass;
    char *   method;
    char *   dist;
    SV *     initialid_ref;

    PREINIT:
    SV  *    clusterid_ref;
    int *    clusterid;
    int      nobjects;
    int      ndata;
    double   error;
    int      ifound;
    int      ok;

    double  * weight;
    double ** matrix;
    int    ** mask;


    PPCODE:
    /* ------------------------
     * Don't check the parameters, because we rely on the Perl
     * caller to check most parameters.
     */

    /* ------------------------
     * Malloc space for the return values from the library function
     */
    if (transpose==0) {
        nobjects = nrows;
        ndata = ncols;
    } else {
        nobjects = ncols;
        ndata = nrows;
    }
    clusterid = malloc(nobjects * sizeof(int) );
    if (!clusterid) {
        croak("memory allocation failure in _kcluster\n");
    }

    /* ------------------------
     * Convert data and mask matrices and the weight array
     * from C to Perl.  Also check for errors, and ignore the
     * mask or the weight array if there are any errors. 
     */
    ok = malloc_matrices( aTHX_ weight_ref, &weight, ndata, 
                data_ref,   &matrix,
                mask_ref,   &mask,  
                nrows,      ncols);
    if (!ok) {
        free(clusterid);
        croak("failed to read input data for _kcluster\n");
    }

    /* ------------------------
     * Copy initialid to clusterid, if needed
     */

    if (npass==0) {
        copy_row_perl2c_int(aTHX_ initialid_ref, clusterid);
    }

    /* ------------------------
     * Run the library function
     */
    kcluster( 
        nclusters, nrows, ncols, 
        matrix, mask, weight, transpose,
        npass, method[0], dist[0], clusterid,  &error, &ifound
        
    );

    /* ------------------------
     * Convert generated C matrices to Perl matrices
     */
    clusterid_ref =    row_c2perl_int(aTHX_ clusterid, nobjects);

    /* ------------------------
     * Push the new Perl matrices onto the return stack
     */
    XPUSHs(sv_2mortal( clusterid_ref   ));
    XPUSHs(sv_2mortal( newSVnv(error) ));
    XPUSHs(sv_2mortal( newSViv(ifound) ));

    /* ------------------------
     * Free what we've malloc'ed 
     */
    free(clusterid);
    free_matrix_int(mask,     nrows);
    free_matrix_dbl(matrix,   nrows);
    free(weight);

    /* Finished _kcluster() */



void
_kmedoids(nclusters,nobjects,distancematrix_ref,npass,initialid_ref)
    int      nclusters;
    int      nobjects;
    SV *     distancematrix_ref;
    int      npass;
    SV *     initialid_ref;


    PREINIT:
    double** distancematrix;
    SV  *    clusterid_ref;
    int *    clusterid;
    double   error;
    int      ifound;



    PPCODE:
    /* ------------------------
     * Don't check the parameters, because we rely on the Perl
     * caller to check most parameters.
     */

    /* ------------------------
     * Malloc space for the return values from the library function
     */
    clusterid = malloc(nobjects * sizeof(int));
    if (!clusterid) {
        croak("memory allocation failure in _kmedoids\n");
    }

    /* ------------------------
     * Convert data and mask matrices and the weight array
     * from C to Perl.  Also check for errors, and ignore the
     * mask or the weight array if there are any errors. 
     */
    distancematrix = parse_distance(aTHX_ distancematrix_ref, nobjects);
    if (!distancematrix) {
        free(clusterid);
            croak("failed to allocate memory for distance matrix in _kmedoids\n");
    }

    /* ------------------------
     * Copy initialid to clusterid, if needed
     */

    if (npass==0) {
        copy_row_perl2c_int(aTHX_ initialid_ref, clusterid);
    }

    /* ------------------------
     * Run the library function
     */
    kmedoids( 
        nclusters, nobjects, 
        distancematrix, npass, clusterid, 
        &error, &ifound
    );

    if(ifound==-1) {
        free(clusterid);
        free_ragged_matrix_dbl(distancematrix, nobjects);
            croak("memory allocation failure in _kmedoids\n");
    }
    else if(ifound==0) {
        free(clusterid);
        free_ragged_matrix_dbl(distancematrix, nobjects);
            croak("error in input arguments in kmedoids\n");
    }
    else {

        /* ------------------------
         * Convert generated C matrices to Perl matrices
         */
        clusterid_ref =    row_c2perl_int(aTHX_ clusterid, nobjects);

        /* ------------------------
         * Push the new Perl matrices onto the return stack

perl/Cluster.xs  view on Meta::CPAN

        free(cluster1);
        free(cluster2);
            croak("failed to read input data for _clusterdistance\n");
    }

    /* ------------------------
     * Run the library function
     */
    distance = clusterdistance( 
        nrows, ncols, 
        matrix, mask, weight,
        cluster1_len, cluster2_len, cluster1, cluster2,
        dist[0], method[0], transpose
    );

    RETVAL = distance;

    /* ------------------------
     * Free what we've malloc'ed 
     */
    free_matrix_int(mask,     nrows);
    free_matrix_dbl(matrix,   nrows);
    free(weight);
    free(cluster1);
    free(cluster2);

    /* Finished _clusterdistance() */

    OUTPUT:
    RETVAL



void
_clustercentroids(nclusters,nrows,ncols,data_ref,mask_ref,clusterid_ref,transpose,method)
    int      nclusters;
    int      nrows;
    int      ncols;
    SV *     data_ref;
    SV *     mask_ref;
    SV *     clusterid_ref;
    int      transpose;
    char *   method;

    PREINIT:
    SV  *    cdata_ref;
    SV  *    cmask_ref;
    int     * clusterid;

    double ** matrix;
    int    ** mask;

    double ** cdata;
    int    ** cmask;
    int       cnrows = 0; /* Initialize to make the compiler shut up */
    int       cncols = 0; /* Initialize to make the compiler shut up */

    int i;
    int ok;

    PPCODE:

    /* ------------------------
     * Don't check the parameters, because we rely on the Perl
     * caller to check most paramters.
     */
        if (transpose==0)
        {    cnrows = nclusters;
             cncols = ncols;
        }
        else if (transpose==1)
        {    cnrows = nrows;
             cncols = nclusters;
        }

    /* ------------------------
     * Convert cluster index Perl arrays to C arrays
     */
    clusterid = malloc_row_perl2c_int(aTHX_ clusterid_ref);
    if (!clusterid) {
        croak("memory allocation failure in _clustercentroids\n");
    }

    /* ------------------------
     * Convert data and mask matrices and the weight array
     * from C to Perl.  Also check for errors, and ignore the
     * mask or the weight array if there are any errors. 
     * Set nweights to the correct number of weights.
     */
    ok = malloc_matrices( aTHX_ NULL, NULL, 0, 
                data_ref,   &matrix,
                mask_ref,   &mask,  
                nrows,      ncols);
    if (!ok) {
        free(clusterid);
            croak("failed to read input data for _clustercentroids\n");
    }


    /* ------------------------
     * Create the output variables cdata and cmask.
     */
    i = 0;
    cdata = malloc(cnrows * sizeof(double*));
    cmask = malloc(cnrows * sizeof(int*));
    if (cdata && cmask) {
        for ( ; i < cnrows; i++) {
            cdata[i] = malloc(cncols*sizeof(double));
            cmask[i] = malloc(cncols*sizeof(int));
            if (!cdata[i] || !cmask[i]) break;
        }
    }
    if (i < cnrows)
    {
        if (cdata[i]) free(cdata[i]);
        if (cmask[i]) free(cmask[i]);
        while (--i >= 0) {
            free(cdata[i]);
            free(cmask[i]);
        }
        if (cdata) free(cdata);

perl/Cluster.xs  view on Meta::CPAN

    /* ------------------------
     * Run the library function
     */
    ok = getclustercentroids(
               nclusters, nrows, ncols,
               matrix, mask, clusterid,
               cdata, cmask, transpose, method[0]);

    if (ok) {
            /* ------------------------
             * Convert generated C matrices to Perl matrices
             */
            cdata_ref = matrix_c2perl_dbl(aTHX_ cdata, cnrows, cncols);
            cmask_ref = matrix_c2perl_int(aTHX_ cmask, cnrows, cncols);

            /* ------------------------
             * Push the new Perl matrices onto the return stack
             */
            XPUSHs(sv_2mortal( cdata_ref   ));
            XPUSHs(sv_2mortal( cmask_ref   ));
    }

    /* ------------------------
     * Free what we've malloc'ed 
     */
    free_matrix_int(mask,     nrows);
    free_matrix_dbl(matrix,   nrows);
    free_matrix_int(cmask,    cnrows);
    free_matrix_dbl(cdata,    cnrows);
    free(clusterid);

    if (!ok) {
        croak("memory allocation failure in _clustercentroids\n");
    }
    /* Finished _clustercentroids() */

void
_distancematrix(nrows,ncols,data_ref,mask_ref,weight_ref,transpose,dist)
    int      nrows;
    int      ncols;
    SV *     data_ref;
    SV *     mask_ref;
    SV *     weight_ref;
    int      transpose;
    char *   dist;

    PREINIT:
    SV  *    matrix_ref;
    int      nobjects;
    int      ndata;

    double ** data;
    int    ** mask;
    double  * weight;
    double ** matrix;

    int       i;
    int       ok;


    PPCODE:
    /* ------------------------
     * Don't check the parameters, because we rely on the Perl
     * caller to check most parameters.
     */

    /* ------------------------
     * Malloc space for the return values from the library function
     */
        if (transpose==0) {
        nobjects = nrows;
        ndata = ncols;
    } else {
        nobjects = ncols;
        ndata = nrows;
    }

    /* ------------------------
     * Convert data and mask matrices and the weight array
     * from C to Perl.  Also check for errors, and ignore the
     * mask or the weight array if there are any errors. 
     */
    ok = malloc_matrices( aTHX_
        weight_ref, &weight, ndata, 
        data_ref,   &data,
        mask_ref,   &mask,  
        nrows,      ncols
    );
    if (!ok) {
        croak("failed to read input data for _distancematrix");
    }

    /* Set up the ragged array */
    matrix = malloc(nobjects*sizeof(double*));
    if (matrix) {
        matrix[0] = NULL;
        for (i = 1; i < nobjects; i++) {
            matrix[i] = malloc(i*sizeof(double));
            if (matrix[i]==NULL) {
                while (--i >= 0) free(matrix[i]);
                free(matrix);
                matrix = NULL;
                break;
            }
        }
    }
    if (!matrix) {
        free_matrix_int(mask, nrows);
        free_matrix_dbl(data, nrows);
        free(weight);
        croak("failed to allocate memory for distance matrix");
    }



    /* ------------------------
     * Run the library function
     */
    distancematrix(nrows,
                   ncols,
                   data,
                   mask,
                   weight,
                   dist[0],
                   transpose,
                   matrix);

    /* ------------------------
     * Convert generated C matrices to Perl matrices
     */
    matrix_ref  = ragged_matrix_c2perl_dbl(aTHX_ matrix,  nobjects);

    /* ------------------------
     * Push the new Perl matrices onto the return stack
     */
    XPUSHs(sv_2mortal(matrix_ref));

    /* ------------------------
     * Free what we've malloc'ed 
     */
    free_ragged_matrix_dbl(matrix, nobjects);
    free_matrix_int(mask, nrows);
    free_matrix_dbl(data, nrows);
    free(weight);

    /* Finished _distancematrix() */


void
_somcluster(nrows,ncols,data_ref,mask_ref,weight_ref,transpose,nxgrid,nygrid,inittau,niter,dist)
    int      nrows;
    int      ncols;
    SV *     data_ref;
    SV *     mask_ref;
    SV *     weight_ref;
    int      transpose;
    int      nxgrid;
    int      nygrid;
    double   inittau;
    int      niter;
    char *   dist;

    PREINIT:
    int      (*clusterid)[2];
    SV *  clusterid_ref;
    double*** celldata;

    double  * weight;
    double ** matrix;
    int    ** mask;

    int ok;

    int i;
    AV * matrix_av;
    const int ndata = transpose ? nrows : ncols;
    const int nelements = transpose ? ncols : nrows;

    PPCODE:
    /* ------------------------
     * Don't check the parameters, because we rely on the Perl
     * caller to check most paramters.
     */

    /* ------------------------
     * Allocate space for clusterid[][2]. 
     */
    clusterid = malloc(nelements*sizeof(int[2]));
    if (!clusterid) {
        croak("memory allocation failure in _somcluster\n");
    }
    celldata  =  0;
    /* Don't return celldata, for now at least */


    /* ------------------------
     * Convert data and mask matrices and the weight array
     * from C to Perl.  Also check for errors, and ignore the
     * mask or the weight array if there are any errors. 
     * Set nweights to the correct number of weights.
     */
    ok = malloc_matrices( aTHX_ weight_ref, &weight, ndata, 
                data_ref,   &matrix,
                mask_ref,   &mask,  
                nrows,      ncols);
    if (!ok) {
            croak("failed to read input data for _somcluster\n");
    }

    /* ------------------------
     * Run the library function
     */
    somcluster( 
        nrows, ncols, 
        matrix, mask, weight,
        transpose, nxgrid, nygrid, inittau, niter,
        dist[0], celldata, clusterid
    );

    /* ------------------------
     * Convert generated C matrices to Perl matrices
     */
    matrix_av = newAV();
    for(i=0; i<nelements; ++i) {
        SV* row_ref;
        AV* row_av = newAV();
        av_push(row_av, newSViv(clusterid[i][0]));
        av_push(row_av, newSViv(clusterid[i][1]));
        row_ref = newRV((SV*)row_av);
        av_push(matrix_av, row_ref);
    }
    clusterid_ref = newRV_noinc((SV*)matrix_av);

    /* ------------------------
     * Push the new Perl matrices onto the return stack
     */
    XPUSHs(sv_2mortal( clusterid_ref   ));

    /* ------------------------
     * Free what we've malloc'ed 
     */
    free_matrix_int(mask,     nrows);
    free_matrix_dbl(matrix,   nrows);
    free(weight);
    free(clusterid);

    /* Finished _somcluster() */


void
_pca(nrows, ncols, data_ref)
    int      nrows;
    int      ncols;
    SV * data_ref;

    PREINIT:
    double** u;
    double** v;
    double* w;
    double* m;
    int i;
    int j;
    int nmin;
    int error;
    SV * mean_ref;
    SV * coordinates_ref;
    SV * pc_ref;
    SV * eigenvalues_ref;

    PPCODE:
    if(SvTYPE(SvRV(data_ref)) != SVt_PVAV) { 
        croak("argument to _pca is not an array reference\n");
    }
    nmin = nrows < ncols ? nrows : ncols;
    /* -- Create the output variables -------------------------------------- */
    u = parse_data(aTHX_ data_ref, NULL);
    w = malloc(nmin*sizeof(double));
    v = malloc(nmin*sizeof(double*));
    m = malloc(ncols*sizeof(double));
    if (v) {
        for (i = 0; i < nmin; i++) {
            v[i] = malloc(nmin*sizeof(double));
            if (!v[i]) break;
        }
        if (i < nmin) { /* then we encountered the break */
            while (i-- > 0) free(v[i]);
            free(v);
            v = NULL;
        }
    }
    if (!u || !v || !w || !m) {
        if (u) free(u);
        if (v) free(v);
        if (w) free(w);
        if (m) free(m);
        croak("memory allocation failure in _pca\n");
    }
    /* -- Calculate the mean of each column ------------------------------ */
    for (j = 0; j < ncols; j++) {
        m[j] = 0.0;
        for (i = 0; i < nrows; i++) m[j] += u[i][j];
        m[j] /= nrows;
    }
    /* -- Subtract the mean of each column ------------------------------- */
    for (i = 0; i < nrows; i++)
        for (j = 0; j < ncols; j++)
            u[i][j] -= m[j];
    error = pca(nrows, ncols, u, v, w);
    if (error==0) {
        /* Convert the C variables to Perl variables */
        mean_ref = row_c2perl_dbl(aTHX_ m, ncols);
        if (nrows >= ncols) {
            coordinates_ref = matrix_c2perl_dbl(aTHX_ u, nrows, ncols);
            pc_ref = matrix_c2perl_dbl(aTHX_ v, nmin, nmin);
        }
        else /* nrows < ncols */ {
            pc_ref = matrix_c2perl_dbl(aTHX_ u, nrows, ncols);
            coordinates_ref = matrix_c2perl_dbl(aTHX_ v, nmin, nmin);
        }
        eigenvalues_ref = row_c2perl_dbl(aTHX_ w, nmin);
    }
    for (i = 0; i < nrows; i++) free(u[i]);
    for (i = 0; i < nmin; i++) free(v[i]);
    free(u);
    free(v);
    free(w);
    free(m);
    if (error==-1)
        croak("Insufficient memory for principal components analysis");
    if (error > 0)



( run in 1.167 second using v1.01-cache-2.11-cpan-71847e10f99 )