view release on metacpan or  search on metacpan

perl/Cluster.xs  view on Meta::CPAN

        croak("memory allocation failure in _clusterdistance\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.
     */
    nweights = (transpose==0) ? ncols : nrows;
    ok = malloc_matrices( aTHX_ weight_ref, &weight, nweights, 
                data_ref,   &matrix,
                mask_ref,   &mask,  
                nrows,      ncols);
    if (!ok) {
        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);
        if (cmask) free(cmask);
        free(clusterid);
        free_matrix_int(mask,     nrows);
        free_matrix_dbl(matrix,   nrows);
        croak("memory allocation failure in _clustercentroids\n");
    }

    /* ------------------------
     * 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) {