view release on metacpan or  search on metacpan

perl/Cluster.xs  view on Meta::CPAN

    } else {
        return 0;
    }
}



/* -------------------------------------------------
 * Convert a Perl 2D matrix into a 2D matrix of C doubles.
 * If no data are masked, mask can be passed as NULL.
 * NOTE: on errors this function returns a value greater than zero.
 */
static double**
parse_data(pTHX_ SV * matrix_ref, int** mask) {

    AV * matrix_av;
    SV * row_ref;
    AV * row_av;
    SV * cell;

    int type, i, j, nrows, ncols, n;

    double** matrix;

    /* NOTE -- we will just assume that matrix_ref points to an arrayref,
     * and that the first item in the array is itself an arrayref.
     * The calling perl functions must check this before we get this pointer.  
     * (It's easier to implement these checks in Perl rather than C.)
     * The value of perl_rows is now fixed. But the value of
     * rows will be decremented, if we skip any (invalid) Perl rows.
     */
    matrix_av  = (AV *) SvRV(matrix_ref);
    nrows = (int) av_len(matrix_av) + 1;

    if(nrows <= 0) {
        return NULL;
    }
    matrix   = malloc(nrows*sizeof(double*));
    if (!matrix) {
        return NULL;
    }

    row_ref  = *(av_fetch(matrix_av, (I32) 0, 0)); 
    row_av   = (AV *) SvRV(row_ref);
    ncols    = (int) av_len(row_av) + 1;


    /* ------------------------------------------------------------ 
     * Loop once for each row in the Perl matrix, and convert it to
     * C doubles. 
     */
    for (i=0; i < nrows; i++) { 

        row_ref = *(av_fetch(matrix_av, (I32) i, 0)); 

        if(! SvROK(row_ref) ) {

            if(warnings_enabled(aTHX))
                Perl_warn(aTHX_ 
                    "Row %d: Wanted array reference, but "
                    "got a scalar. No row to process?\n", i);
            break;
        }

        row_av = (AV *) SvRV(row_ref);
        type = SvTYPE(row_av); 
    
        /* Handle unexpected cases */
        if(type != SVt_PVAV ) {

             /* Reference doesn't point to an array at all. */
            if(warnings_enabled(aTHX))
                Perl_warn(aTHX_ 
                    "Row %d: Wanted array reference, but got "
                    "a reference to something else (%d)\n",
                    i, type);
            break;

        }

        n = (int) av_len(row_av) + 1;
        if (n != ncols) {
            /* All rows in the matrix should have the same
             * number of columns. */
            if(warnings_enabled(aTHX))
                Perl_warn(aTHX_ 
                    "Row %d: Contains %d columns "
                    "(expected %d)\n", i, n, ncols);
            break;
        }

        matrix[i] = malloc(ncols*sizeof(double));
        if (!matrix[i])
            break;

        /* Loop once for each cell in the row. */
        for (j=0; j < ncols; j++) { 
        
            double num;
            if (!mask || mask[i][j]) {
                cell = *(av_fetch(row_av, (I32) j, 0)); 
                if(extract_double_from_scalar(aTHX_ cell,&num) <= 0) {    
                    if(warnings_enabled(aTHX))
                        Perl_warn(aTHX_ 
                            "Row %d col %d: Value is not "
                                                    "a number.\n", i, j);
                    free(matrix[i]); /* not included below */
                    break;
                }
            }
            else {
                /* Don't read the value if it is masked.
                 * Set it to some arbitrary value. */
                num = 0.0;
            }
            matrix[i][j] = num;

        } /* End for (j=0; j < ncols; j++) */
        if (j < ncols) break;

    } /* End for (i=0; i < nrows; i++) */

perl/Cluster.xs  view on Meta::CPAN

        free(matrix);
        matrix = NULL;
    }

    return matrix;
}


/* -------------------------------------------------
 * Convert a Perl 2D matrix into a 2D matrix of C ints.
 * On errors this function returns a value greater than zero.
 */
static int**
parse_mask(pTHX_ SV * matrix_ref) {

    AV * matrix_av;
    SV * row_ref;
    AV * row_av;
    SV * cell;

    int type, i, j, nrows, ncols, n;

    int** matrix;

    /* NOTE -- we will just assume that matrix_ref points to an arrayref,
     * and that the first item in the array is itself an arrayref.
     * The calling perl functions must check this before we get this pointer.  
     * (It's easier to implement these checks in Perl rather than C.)
     * The value of perl_rows is now fixed. But the value of
     * rows will be decremented, if we skip any (invalid) Perl rows.
     */
    matrix_av = (AV *) SvRV(matrix_ref);
    nrows = (int) av_len(matrix_av) + 1;

    if(nrows <= 0) {
        return NULL;  /* Caller must handle this case!! */
    }
    matrix    = malloc(nrows * sizeof(int *) );
    if (!matrix) {
        return NULL;
    }

    row_ref   = *(av_fetch(matrix_av, (I32) 0, 0)); 
    row_av    = (AV *) SvRV(row_ref);
    ncols     = (int) av_len(row_av) + 1;



    /* ------------------------------------------------------------ 
     * Loop once for each row in the Perl matrix, and convert it to C ints. 
     */
    for (i=0; i < nrows; i++) { 

        row_ref = *(av_fetch(matrix_av, (I32) i, 0)); 

        if(! SvROK(row_ref) ) {

            if(warnings_enabled(aTHX))
                Perl_warn(aTHX_ 
                    "Row %d: Wanted array reference, but "
                    "got a scalar. No row to process?\n", i);
            break;
        }

        row_av = (AV *) SvRV(row_ref);
        type = SvTYPE(row_av); 
    
        /* Handle unexpected cases */
        if(type != SVt_PVAV ) {

             /* Reference doesn't point to an array at all. */
            if(warnings_enabled(aTHX))
                Perl_warn(aTHX_ 
                    "Row %d: Wanted array reference, but got "
                    "a reference to something else (%d)\n",
                    i, type);
            break;

        }

        n = (int) av_len(row_av) + 1;
        if (n != ncols) {
            /* All rows in the matrix should have the same
             * number of columns. */
            if(warnings_enabled(aTHX))
                Perl_warn(aTHX_ 
                    "Row %d: Contains %d columns "
                    "(expected %d)\n", i, n, ncols);
            break;
        }

        matrix[i] = malloc(ncols * sizeof(int) );
        if (!matrix[i]) {
            break;
        }

        /* Loop once for each cell in the row. */
        for (j=0; j < ncols; ++j) { 
            double num;
            cell = *(av_fetch(row_av, (I32) j, 0)); 
            if(extract_double_from_scalar(aTHX_ cell,&num) <= 0) {    
                if(warnings_enabled(aTHX))
                    Perl_warn(aTHX_
                        "Row %d col %d: Value is not "
                        "a number.\n", i, j);
                free(matrix[i]); /* not included below */
                break;
            }
            matrix[i][j] = (int) num;

        } /* End for (j=0; j < ncols; j++) */
        if (j < ncols) break;

    } /* End for (i=0; i < nrows; i++) */

    if (i < nrows) { /* break statement encountered */
        nrows = i;
        for (i = 0; i < nrows; i++) free(matrix[i]);
        free(matrix);
        matrix = NULL;
    }