view release on metacpan or  search on metacpan

perl/Cluster.xs  view on Meta::CPAN

    }

    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");
    }

    flag = malloc((2*n+1)*sizeof(int));
    if(flag) {
         int j;
        for (i = 0; i < 2*n+1; i++) flag[i] = 0;
        for (i = 0; i < n; i++) {
            j = tree->nodes[i].left;
            if (j < 0) {
                j = -j-1;
                if (j>=i) break;
            }
            else j+=n;
            if (flag[j]) break;
            flag[j] = 1;
            j = tree->nodes[i].right;
            if (j < 0) {
                j = -j-1;
                if (j>=i) break;
            }
            else j+=n;
            if (flag[j]) break;
            flag[j] = 1;
        }
        free(flag);
    }

    if (!flag || i < n) {
        /* break encountered */
        free(tree->nodes);
        free(tree);
        croak("the array of nodes passed to Algorithm::Cluster::Tree::new does not represent a valid tree\n");
    }

    RETVAL = newSViv(0);
    obj = newSVrv(RETVAL, class);
    sv_setiv(obj, PTR2IV(tree));
    SvREADONLY_on(obj);

    OUTPUT:
    RETVAL

int
length (obj)
    SV* obj
    CODE:
    RETVAL = (INT2PTR(Tree*,SvIV(SvRV(obj))))->n;
    OUTPUT:
    RETVAL


SV *
get (obj, index)
    SV* obj
    int index
    PREINIT:
    Tree* tree;
    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;
    }

perl/Cluster.xs  view on Meta::CPAN

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

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

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

    OUTPUT:
    RETVAL


SV *
_treecluster(nrows,ncols,data_ref,mask_ref,weight_ref,transpose,dist,method)
    int      nrows;
    int      ncols;
    SV *     data_ref;
    SV *     mask_ref;
    SV *     weight_ref;
    int      transpose;
    char *   dist;
    char *   method;

    PREINIT:
    Node*    nodes;

    double  * weight = NULL;
    double ** matrix = NULL;
    int    ** mask   = NULL;
    double ** distancematrix = NULL;
    const int ndata = transpose ? nrows : ncols;
    const int nelements = transpose ? ncols : nrows;

    CODE:
    /* ------------------------
     * Don't check the parameters, because we rely on the Perl
     * caller to check most paramters.
     */
    /* ------------------------
     * 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. 
     */
    if (is_distance_matrix(aTHX_ data_ref)) {
        distancematrix = parse_distance(aTHX_ data_ref, nelements);
        if (!distancematrix) {
                croak("memory allocation failure in _treecluster\n");
        }
    } else {
        int ok;
        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 _treecluster\n");
        }
    }

    /* ------------------------
     * Run the library function
     */
    nodes = treecluster(nrows, ncols, matrix, mask, weight, transpose,