/* Create a one dimensional box */ Datum cube_f8_f8(PG_FUNCTION_ARGS) { double x0 = PG_GETARG_FLOAT8(0); double x1 = PG_GETARG_FLOAT8(1); NDBOX *result; int size; if (x0 == x1) { size = POINT_SIZE(1); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, 1); SET_POINT_BIT(result); result->x[0] = x0; } else { size = CUBE_SIZE(1); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, 1); result->x[0] = x0; result->x[1] = x1; } PG_RETURN_NDBOX(result); }
/* Add a dimension to an existing cube */ Datum cube_c_f8_f8(PG_FUNCTION_ARGS) { NDBOX *cube = PG_GETARG_NDBOX(0); double x1 = PG_GETARG_FLOAT8(1); double x2 = PG_GETARG_FLOAT8(2); NDBOX *result; int size; int i; if (DIM(cube) + 1 > CUBE_MAX_DIM) ereport(ERROR, (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED), errmsg("can't extend cube"), errdetail("A cube cannot have more than %d dimensions.", CUBE_MAX_DIM))); if (IS_POINT(cube) && (x1 == x2)) { size = POINT_SIZE((DIM(cube) + 1)); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, DIM(cube) + 1); SET_POINT_BIT(result); for (i = 0; i < DIM(cube); i++) result->x[i] = cube->x[i]; result->x[DIM(result) - 1] = x1; } else { size = CUBE_SIZE((DIM(cube) + 1)); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, DIM(cube) + 1); for (i = 0; i < DIM(cube); i++) { result->x[i] = LL_COORD(cube, i); result->x[DIM(result) + i] = UR_COORD(cube, i); } result->x[DIM(result) - 1] = x1; result->x[2 * DIM(result) - 1] = x2; } PG_FREE_IF_COPY(cube, 0); PG_RETURN_NDBOX(result); }
void SetDim2(SEXP array, int x1, int x2) { SEXP _dim; PROTECT(_dim = NEW_INTEGER(2)); INTEGER_POINTER(_dim)[0] = x1; INTEGER_POINTER(_dim)[1] = x2; SET_DIM(array, _dim); UNPROTECT_PTR(_dim); }
void SetDim3(SEXP array, int x1, int x2, int x3) { SEXP _dim; PROTECT(_dim = NEW_INTEGER(3)); INTEGER_POINTER(_dim)[0] = x1; INTEGER_POINTER(_dim)[1] = x2; INTEGER_POINTER(_dim)[2] = x3; SET_DIM(array, _dim); UNPROTECT_PTR(_dim); }
Datum cube_subset(PG_FUNCTION_ARGS) { NDBOX *c = PG_GETARG_NDBOX(0); ArrayType *idx = PG_GETARG_ARRAYTYPE_P(1); NDBOX *result; int size, dim, i; int *dx; if (array_contains_nulls(idx)) ereport(ERROR, (errcode(ERRCODE_ARRAY_ELEMENT_ERROR), errmsg("cannot work with arrays containing NULLs"))); dx = (int32 *) ARR_DATA_PTR(idx); dim = ARRNELEMS(idx); if (dim > CUBE_MAX_DIM) ereport(ERROR, (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED), errmsg("array is too long"), errdetail("A cube cannot have more than %d dimensions.", CUBE_MAX_DIM))); size = IS_POINT(c) ? POINT_SIZE(dim) : CUBE_SIZE(dim); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, dim); if (IS_POINT(c)) SET_POINT_BIT(result); for (i = 0; i < dim; i++) { if ((dx[i] <= 0) || (dx[i] > DIM(c))) { pfree(result); ereport(ERROR, (errcode(ERRCODE_ARRAY_ELEMENT_ERROR), errmsg("Index out of bounds"))); } result->x[i] = c->x[dx[i] - 1]; if (!IS_POINT(c)) result->x[i + dim] = c->x[dx[i] + DIM(c) - 1]; } PG_FREE_IF_COPY(c, 0); PG_RETURN_NDBOX(result); }
/* Create a one dimensional box with identical upper and lower coordinates */ Datum cube_f8(PG_FUNCTION_ARGS) { double x = PG_GETARG_FLOAT8(0); NDBOX *result; int size; size = POINT_SIZE(1); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, 1); SET_POINT_BIT(result); result->x[0] = x; PG_RETURN_NDBOX(result); }
SEXP mat44_to_SEXP(mat44 *mat) { SEXP ret_val; int c,r; PROTECT(ret_val = NEW_NUMERIC(4*4)); for(r=0;r<4;++r) for(c=0;c<4;++c) NUMERIC_POINTER(ret_val)[r+c*4]=(double)(mat->m[r][c]); SEXP dim; PROTECT(dim=NEW_INTEGER(2)); INTEGER_POINTER(dim)[0]=4; INTEGER_POINTER(dim)[1]=4; SET_DIM(ret_val,dim); UNPROTECT(2); return ret_val; }
// a is an array with e.g. a[,,1] being a matrix of data in the first image SEXP amsr_composite(SEXP a) { //Rprintf("amsr_composite ...\n"); PROTECT(a = AS_RAW(a)); unsigned char *ap = RAW_POINTER(a); unsigned int n1 = INTEGER(GET_DIM(a))[0]; unsigned int n2 = INTEGER(GET_DIM(a))[1]; unsigned int n3 = INTEGER(GET_DIM(a))[2]; unsigned int n12 = n1 * n2; //Rprintf("amsr_composite n1=%d n2=%d n3=%d n12=%d\n", n1, n2, n3, n12); SEXP res; PROTECT(res = NEW_RAW(n12)); unsigned char *resp = RAW_POINTER(res); unsigned char A = 'a'; // assignment prevents compiler warning at line 145 for (int i = 0; i < n12; i++) { double sum = 0.0; int nsum = 0; //if (i < 300) Rprintf("i=%d:\n", i); for (int i3 = 0; i3 < n3; i3++) { A = ap[i + n12*i3]; if (A < 0xfb) { sum += A; nsum++; //if (i < 300) Rprintf(" i3=%3d A=%3d=0x%02x sum=%5.1f nsum=%d\n", i3, (int)A, A, sum, nsum); } else { //if (i < 300) Rprintf(" i3=%3d A=%3d=0x%02x SKIPPED\n", i3, (int)A, A); } } if (nsum) resp[i] = (unsigned char)floor(0.5 + sum/nsum); else resp[i] = A; // will be >= 0xfb ... we inherit the NA type from last image //if (i < 300) Rprintf(" resp=%d=0x%02x\n", (int)resp[i], resp[i]); } SEXP resdim; PROTECT(resdim = allocVector(INTSXP, 2)); int *resdimp = INTEGER_POINTER(resdim); resdimp[0] = n1; resdimp[1] = n2; SET_DIM(res, resdim); UNPROTECT(3); return res; }
/* type: 0=CHARSXP, 1=STRSXP, 2=RAWSXP as_matrix: 0 or 1, ignored when type is 0 q_len, q_break, s_len: ignored when type is 0 */ static SEXP make_encoding_from_CharAE(const CharAE *buf, int type, int as_matrix, int q_len, int q_break, int s_len) { SEXP ans, ans_elt, ans_dim; int buf_nelt, i, nrow; buf_nelt = _CharAE_get_nelt(buf); if (type == 0 || (type == 1 && !as_matrix)) { PROTECT(ans = mkCharLen(buf->elts, buf_nelt)); if (type == 1) { PROTECT(ans = ScalarString(ans)); UNPROTECT(1); } UNPROTECT(1); return ans; } if (type == 1) { PROTECT(ans = NEW_CHARACTER(buf_nelt)); for (i = 0; i < buf_nelt; i++) { PROTECT(ans_elt = mkCharLen(buf->elts + i, 1)); SET_STRING_ELT(ans, i, ans_elt); UNPROTECT(1); } } else { PROTECT(ans = _new_RAW_from_CharAE(buf)); } if (as_matrix) { nrow = q_len; if (q_break != 0) nrow += 2; PROTECT(ans_dim = NEW_INTEGER(2)); INTEGER(ans_dim)[0] = nrow; INTEGER(ans_dim)[1] = s_len; SET_DIM(ans, ans_dim); UNPROTECT(1); } UNPROTECT(1); return ans; }
SEXP as_dummy(SEXP R_x) { int n, l, i, j; SEXP R_obj, R_tmp; n = LENGTH(R_x); l = LENGTH(GET_LEVELS(R_x)); if (l == 0) return R_NilValue; PROTECT(R_obj = NEW_LOGICAL(n*l)); for (i = 0; i < n*l; i++) /* this sucks! */ LOGICAL(R_obj)[i] = FALSE; for (i = 0; i < n; i++) { j = INTEGER(R_x)[i]; if (j == NA_INTEGER) continue; LOGICAL(R_obj)[i+(j-1)*n] = TRUE; } PROTECT(R_tmp = NEW_INTEGER(2)); INTEGER(R_tmp)[0] = n; INTEGER(R_tmp)[1] = l; SET_DIM(R_obj, R_tmp); UNPROTECT(1); SET_LEVELS(R_obj, duplicate(GET_LEVELS(R_x))); UNPROTECT(1); return R_obj; }
SEXP vdp_softmax(SEXP matrix_M) { int dim1, dim2; double *in, *out; SEXP output, dims; /******************** input variables ********************/ in = NUMERIC_POINTER(matrix_M); dim1 = INTEGER_POINTER(GET_DIM(matrix_M))[0]; dim2 = INTEGER_POINTER(GET_DIM(matrix_M))[1]; PROTECT(dims = allocVector(INTSXP, 2)); INTEGER(dims)[0] = dim1; INTEGER(dims)[1] = dim2; /******************** output variables ********************/ PROTECT(output = NEW_NUMERIC(dim1*dim2)); SET_DIM(output, dims); out = NUMERIC_POINTER(output); softmax(dim1, dim2, in, out); UNPROTECT(2); return output; }
/* ** Allows the construction of a zero-volume cube from a float[] */ Datum cube_a_f8(PG_FUNCTION_ARGS) { ArrayType *ur = PG_GETARG_ARRAYTYPE_P(0); NDBOX *result; int i; int dim; int size; double *dur; if (array_contains_nulls(ur)) ereport(ERROR, (errcode(ERRCODE_ARRAY_ELEMENT_ERROR), errmsg("cannot work with arrays containing NULLs"))); dim = ARRNELEMS(ur); if (dim > CUBE_MAX_DIM) ereport(ERROR, (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED), errmsg("array is too long"), errdetail("A cube cannot have more than %d dimensions.", CUBE_MAX_DIM))); dur = ARRPTR(ur); size = POINT_SIZE(dim); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, dim); SET_POINT_BIT(result); for (i = 0; i < dim; i++) result->x[i] = dur[i]; PG_RETURN_NDBOX(result); }
SEXP getallLocations(SEXP namesR, SEXP dimR, SEXP atomsR, SEXP selectR, SEXP nb_affyidR) { int nrows, ncols, nb_affyid; int ii, jj; int *names, *atoms, *select; int *nbElements; int iLastElementNA; int x, nAtom; SEXP loc_list; SEXP tmp_dim; nrows = INTEGER_POINTER(dimR)[0]; ncols = INTEGER_POINTER(dimR)[1]; nb_affyid = INTEGER(nb_affyidR)[0]; names = INTEGER_POINTER(namesR); atoms = INTEGER_POINTER(atomsR); select = INTEGER_POINTER(selectR); nbElements = (int *)R_alloc(nb_affyid, sizeof(int)); iLastElementNA = 0; PROTECT(loc_list = NEW_LIST(nb_affyid)); PROTECT(tmp_dim = NEW_INTEGER(2)); for (ii=0; ii<nb_affyid; ii++) { nbElements[ii] = 0; } /* count the number of elemets for each affyid */ for (ii=0; ii<nrows; ii++) { for (jj=0; jj<ncols; jj++) { if (select[ii + nrows * jj] != 1) { continue; } x = names[ii + nrows * jj]; if (x == NA_INTEGER) { x = nb_affyid; } nbElements[x-1]++; } } /* init the list accordingly */ for (ii=0; ii<nb_affyid; ii++) { SET_VECTOR_ELT(loc_list, ii, NEW_INTEGER(nbElements[ii] * 2)); INTEGER_POINTER(tmp_dim)[0] = nbElements[ii]; if (nbElements[ii] == 0) { INTEGER_POINTER(tmp_dim)[1] = 0; } else { INTEGER_POINTER(tmp_dim)[1] = 2; } SET_DIM(VECTOR_ELT(loc_list, ii), tmp_dim); /* extra-paranoia set the locations to NA */ for (jj = 0; jj<nbElements[ii]*2; jj++) { INTEGER_POINTER(VECTOR_ELT(loc_list, ii))[jj] = NA_INTEGER; } } /* fill it */ for (ii=0; ii<nrows; ii++) { for (jj=0; jj<ncols; jj++) { if (select[ii + nrows * jj] != 1) { continue; } x = names[ii + nrows * jj]; /* sanity check */ if (x == NA_INTEGER) { x = nb_affyid; nAtom = iLastElementNA++; } else { nAtom = atoms[ii + nrows * jj]; } if ((nAtom < 0) | (nAtom > nbElements[x-1])) { error("Inconsistency in the Cdf object (slot atom, element [%i,%i])! The atom value %i should be positive and lower than %i for the probeset %i.", ii+1, jj+1, nAtom, nbElements[x-1], x-1); } INTEGER_POINTER(VECTOR_ELT(loc_list, x-1))[nAtom + nbElements[x-1] * 0] = ii+1; INTEGER_POINTER(VECTOR_ELT(loc_list, x-1))[nAtom + nbElements[x-1] * 1] = jj+1; /* iLastElement[x-1]++; */ } } UNPROTECT(2); return loc_list; }
// File based on http://dev.loci.wisc.edu/trac/software/browser/trunk/components/bio-formats/src/loci/formats/in/CellomicsReader.java SEXP readCellomics(const char *filename) { FILE *fin; unsigned char *dat, *pdat; int datsize; SEXP image, dim; int i, width, height, nplanes, nbits, compression; int nprotect; double *dimage; int ret; // init nprotect = 0; // open file fin = fopen(filename, "rb"); if (!fin) error("readCellomics: cannot open file"); // inflate zlib stream fseek(fin, 4, SEEK_SET); ret = inflateData(fin, &dat, &datsize); if (ret!=Z_OK) error("readCellomics: cannot decompress stream"); fclose(fin); // read header width = *(int *)(&dat[4]); height = *(int *)(&dat[8]); nplanes = *(short *)(&dat[12]); nbits = *(short *)(&dat[14]); compression = *(int *)(&dat[16]); if (width*height*nplanes*(nbits/8)+52 > datsize) { error("readCellomics: compressed mode is not yed supported"); } // allocate new image image = PROTECT(allocVector(REALSXP, width * height * nplanes)); nprotect++; if (nplanes==1) PROTECT(dim=allocVector(INTSXP, 2)); else PROTECT(dim=allocVector(INTSXP, 3)); nprotect++; INTEGER(dim)[0] = width; INTEGER(dim)[1] = height; if (nplanes>1) INTEGER(dim)[1] = nplanes; SET_DIM (image, dim); // copy planes dimage = REAL(image); pdat = &dat[52]; if (nbits==8) { for (i=0; i<width*height*nplanes; i++) { *dimage++ = (*((unsigned char *)pdat))/256.0; pdat += sizeof(unsigned char); } } else if (nbits==16) { for (i=0; i<width*height*nplanes; i++) { *dimage++ = (*((unsigned short *)pdat))/65536.0; pdat += sizeof(unsigned short); } } else if (nbits==32) { for (i=0; i<width*height*nplanes; i++) { *dimage++ = (*((unsigned int *)pdat))/4294967296.0; pdat += sizeof(unsigned int); } } else { free(dat); error("readCellomics: unsupported nbits/pixel mode"); } // free dat free(dat); UNPROTECT(nprotect); return(image); }
// examines weights for filtering failure // computes log likelihood and effective sample size // computes (if desired) prediction mean, prediction variance, filtering mean. // it is assumed that ncol(x) == ncol(params). // weights are used in filtering mean computation. // if length(weights) == 1, an unweighted average is computed. // returns all of the above in a named list SEXP pfilter2_computations (SEXP x, SEXP params, SEXP Np, SEXP rw, SEXP rw_sd, SEXP predmean, SEXP predvar, SEXP filtmean, SEXP onepar, SEXP weights, SEXP tol) { int nprotect = 0; SEXP pm = R_NilValue, pv = R_NilValue, fm = R_NilValue; SEXP rw_names, ess, fail, loglik; SEXP newstates = R_NilValue, newparams = R_NilValue; SEXP retval, retvalnames; double *xpm = 0, *xpv = 0, *xfm = 0, *xw = 0, *xx = 0, *xp = 0, *xpw=0; int *xpa=0; SEXP dimX, dimP, newdim, Xnames, Pnames, pindex; SEXP pw=R_NilValue,pa=R_NilValue, psample=R_NilValue; int *dim, *pidx, lv, np; int nvars, npars = 0, nrw = 0, nreps, offset, nlost; int do_rw, do_pm, do_pv, do_fm, do_par_resamp, all_fail = 0; double sum, sumsq, vsq, ws, w, toler; int j, k; PROTECT(dimX = GET_DIM(x)); nprotect++; dim = INTEGER(dimX); nvars = dim[0]; nreps = dim[1]; xx = REAL(x); PROTECT(Xnames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(dimP = GET_DIM(params)); nprotect++; dim = INTEGER(dimP); npars = dim[0]; if (nreps != dim[1]) error("'states' and 'params' do not agree in second dimension"); PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; np = INTEGER(AS_INTEGER(Np))[0]; // number of particles to resample PROTECT(rw_names = GET_NAMES(rw_sd)); nprotect++; // names of parameters undergoing random walk do_rw = *(LOGICAL(AS_LOGICAL(rw))); // do random walk in parameters? do_pm = *(LOGICAL(AS_LOGICAL(predmean))); // calculate prediction means? do_pv = *(LOGICAL(AS_LOGICAL(predvar))); // calculate prediction variances? do_fm = *(LOGICAL(AS_LOGICAL(filtmean))); // calculate filtering means? do_par_resamp = *(LOGICAL(AS_LOGICAL(onepar))); // are all cols of 'params' the same? do_par_resamp = !do_par_resamp || do_rw || (np != nreps); // should we do parameter resampling? PROTECT(ess = NEW_NUMERIC(1)); nprotect++; // effective sample size PROTECT(loglik = NEW_NUMERIC(1)); nprotect++; // log likelihood PROTECT(fail = NEW_LOGICAL(1)); nprotect++; // particle failure? xw = REAL(weights); toler = *(REAL(tol)); // failure tolerance // check the weights and compute sum and sum of squares for (k = 0, w = 0, ws = 0, nlost = 0; k < nreps; k++) { if (xw[k] >= 0) { w += xw[k]; ws += xw[k]*xw[k]; } else { // this particle is lost xw[k] = 0; nlost++; } } if (nlost >= nreps) all_fail = 1; // all particles are lost if (all_fail) { *(REAL(loglik)) = log(toler); // minimum log-likelihood *(REAL(ess)) = 0; // zero effective sample size } else { *(REAL(loglik)) = log(w/((double) nreps)); // mean of weights is likelihood *(REAL(ess)) = w*w/ws; // effective sample size } *(LOGICAL(fail)) = all_fail; if (do_rw) { // indices of parameters undergoing random walk PROTECT(pindex = matchnames(Pnames,rw_names,"parameters")); nprotect++; xp = REAL(params); pidx = INTEGER(pindex); nrw = LENGTH(rw_names); lv = nvars+nrw; } else { pidx = NULL; lv = nvars; } if (do_pm || do_pv) { PROTECT(pm = NEW_NUMERIC(lv)); nprotect++; xpm = REAL(pm); } if (do_pv) { PROTECT(pv = NEW_NUMERIC(lv)); nprotect++; xpv = REAL(pv); } if (do_fm) { if (do_rw) { PROTECT(fm = NEW_NUMERIC(nvars+npars)); nprotect++; } else { PROTECT(fm = NEW_NUMERIC(nvars)); nprotect++; } xfm = REAL(fm); } PROTECT(pa = NEW_INTEGER(np)); nprotect++; xpa = INTEGER(pa); for (j = 0; j < nvars; j++) { // state variables // compute prediction mean if (do_pm || do_pv) { for (k = 0, sum = 0; k < nreps; k++) sum += xx[j+k*nvars]; sum /= ((double) nreps); xpm[j] = sum; } // compute prediction variance if (do_pv) { for (k = 0, sumsq = 0; k < nreps; k++) { vsq = xx[j+k*nvars]-sum; sumsq += vsq*vsq; } xpv[j] = sumsq / ((double) (nreps - 1)); } // compute filter mean if (do_fm) { if (all_fail) { // unweighted average for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]; xfm[j] = ws/((double) nreps); } else { // weighted average for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]*xw[k]; xfm[j] = ws/w; } } } // compute means and variances for parameters (if needed) if (do_rw) { for (j = 0; j < nrw; j++) { offset = pidx[j]; // position of the parameter if (do_pm || do_pv) { for (k = 0, sum = 0; k < nreps; k++) sum += xp[offset+k*npars]; sum /= ((double) nreps); xpm[nvars+j] = sum; } if (do_pv) { for (k = 0, sumsq = 0; k < nreps; k++) { vsq = xp[offset+k*npars]-sum; sumsq += vsq*vsq; } xpv[nvars+j] = sumsq / ((double) (nreps - 1)); } } if (do_fm) { for (j = 0; j < npars; j++) { if (all_fail) { // unweighted average for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]; xfm[nvars+j] = ws/((double) nreps); } else { // weighted average for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]*xw[k]; xfm[nvars+j] = ws/w; } } } } GetRNGstate(); if (!all_fail) { // resample the particles unless we have filtering failure int xdim[2]; //int sample[np]; double *ss = 0, *st = 0, *ps = 0, *pt = 0; // create storage for new states xdim[0] = nvars; xdim[1] = np; PROTECT(newstates = makearray(2,xdim)); nprotect++; setrownames(newstates,Xnames,2); ss = REAL(x); st = REAL(newstates); // create storage for new parameters if (do_par_resamp) { xdim[0] = npars; xdim[1] = np; PROTECT(newparams = makearray(2,xdim)); nprotect++; setrownames(newparams,Pnames,2); ps = REAL(params); pt = REAL(newparams); } PROTECT(pw = NEW_NUMERIC(nreps)); nprotect++; xpw = REAL(pw); for (k = 0; k < nreps; k++) xpw[k]=REAL(weights)[k]; nosort_resamp(nreps,REAL(weights),np,xpa,0); for (k = 0; k < np; k++) { // copy the particles for (j = 0, xx = ss+nvars*xpa[k]; j < nvars; j++, st++, xx++) *st = *xx; if (do_par_resamp) { for (j = 0, xp = ps+npars*xpa[k]; j < npars; j++, pt++, xp++){ *pt = *xp; } } } } else { // don't resample: just drop 3rd dimension in x prior to return PROTECT(newdim = NEW_INTEGER(2)); nprotect++; dim = INTEGER(newdim); dim[0] = nvars; dim[1] = nreps; SET_DIM(x,newdim); setrownames(x,Xnames,2); } if (do_rw) { // if random walk, adjust prediction variance and move particles xx = REAL(rw_sd); xp = (all_fail || !do_par_resamp) ? REAL(params) : REAL(newparams); nreps = (all_fail) ? nreps : np; for (j = 0; j < nrw; j++) { offset = pidx[j]; vsq = xx[j]; if (do_pv) { xpv[nvars+j] += vsq*vsq; } for (k = 0; k < nreps; k++) xp[offset+k*npars] += rnorm(0,vsq); } } renormalize(xpw,nreps,0); PutRNGstate(); PROTECT(retval = NEW_LIST(10)); nprotect++; PROTECT(retvalnames = NEW_CHARACTER(10)); nprotect++; SET_STRING_ELT(retvalnames,0,mkChar("fail")); SET_STRING_ELT(retvalnames,1,mkChar("loglik")); SET_STRING_ELT(retvalnames,2,mkChar("ess")); SET_STRING_ELT(retvalnames,3,mkChar("states")); SET_STRING_ELT(retvalnames,4,mkChar("params")); SET_STRING_ELT(retvalnames,5,mkChar("pm")); SET_STRING_ELT(retvalnames,6,mkChar("pv")); SET_STRING_ELT(retvalnames,7,mkChar("fm")); SET_STRING_ELT(retvalnames,8,mkChar("weight")); SET_STRING_ELT(retvalnames,9,mkChar("pa")); SET_NAMES(retval,retvalnames); SET_ELEMENT(retval,0,fail); SET_ELEMENT(retval,1,loglik); SET_ELEMENT(retval,2,ess); if (all_fail) { SET_ELEMENT(retval,3,x); } else { SET_ELEMENT(retval,3,newstates); } if (all_fail || !do_par_resamp) { SET_ELEMENT(retval,4,params); } else { SET_ELEMENT(retval,4,newparams); } if (do_pm) { SET_ELEMENT(retval,5,pm); } if (do_pv) { SET_ELEMENT(retval,6,pv); } if (do_fm) { SET_ELEMENT(retval,7,fm); } SET_ELEMENT(retval,8,pw); SET_ELEMENT(retval,9,pa); UNPROTECT(nprotect); return(retval); }
/* cube_union_v0 */ NDBOX * cube_union_v0(NDBOX *a, NDBOX *b) { int i; NDBOX *result; int dim; int size; /* trivial case */ if (a == b) return a; /* swap the arguments if needed, so that 'a' is always larger than 'b' */ if (DIM(a) < DIM(b)) { NDBOX *tmp = b; b = a; a = tmp; } dim = DIM(a); size = CUBE_SIZE(dim); result = palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, dim); /* First compute the union of the dimensions present in both args */ for (i = 0; i < DIM(b); i++) { result->x[i] = Min( Min(LL_COORD(a, i), UR_COORD(a, i)), Min(LL_COORD(b, i), UR_COORD(b, i)) ); result->x[i + DIM(a)] = Max( Max(LL_COORD(a, i), UR_COORD(a, i)), Max(LL_COORD(b, i), UR_COORD(b, i)) ); } /* continue on the higher dimensions only present in 'a' */ for (; i < DIM(a); i++) { result->x[i] = Min(0, Min(LL_COORD(a, i), UR_COORD(a, i)) ); result->x[i + dim] = Max(0, Max(LL_COORD(a, i), UR_COORD(a, i)) ); } /* * Check if the result was in fact a point, and set the flag in the datum * accordingly. (we don't bother to repalloc it smaller) */ if (cube_is_point_internal(result)) { size = POINT_SIZE(dim); SET_VARSIZE(result, size); SET_POINT_BIT(result); } return (result); }
/* cube_inter */ Datum cube_inter(PG_FUNCTION_ARGS) { NDBOX *a = PG_GETARG_NDBOX(0); NDBOX *b = PG_GETARG_NDBOX(1); NDBOX *result; bool swapped = false; int i; int dim; int size; /* swap the arguments if needed, so that 'a' is always larger than 'b' */ if (DIM(a) < DIM(b)) { NDBOX *tmp = b; b = a; a = tmp; swapped = true; } dim = DIM(a); size = CUBE_SIZE(dim); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, dim); /* First compute intersection of the dimensions present in both args */ for (i = 0; i < DIM(b); i++) { result->x[i] = Max( Min(LL_COORD(a, i), UR_COORD(a, i)), Min(LL_COORD(b, i), UR_COORD(b, i)) ); result->x[i + DIM(a)] = Min( Max(LL_COORD(a, i), UR_COORD(a, i)), Max(LL_COORD(b, i), UR_COORD(b, i)) ); } /* continue on the higher dimensions only present in 'a' */ for (; i < DIM(a); i++) { result->x[i] = Max(0, Min(LL_COORD(a, i), UR_COORD(a, i)) ); result->x[i + DIM(a)] = Min(0, Max(LL_COORD(a, i), UR_COORD(a, i)) ); } /* * Check if the result was in fact a point, and set the flag in the datum * accordingly. (we don't bother to repalloc it smaller) */ if (cube_is_point_internal(result)) { size = POINT_SIZE(dim); result = repalloc(result, size); SET_VARSIZE(result, size); SET_POINT_BIT(result); } if (swapped) { PG_FREE_IF_COPY(b, 0); PG_FREE_IF_COPY(a, 1); } else { PG_FREE_IF_COPY(a, 0); PG_FREE_IF_COPY(b, 1); } /* * Is it OK to return a non-null intersection for non-overlapping boxes? */ PG_RETURN_NDBOX(result); }
SEXP L2L1VitPath(SEXP obsSeq, SEXP lambda2, SEXP lambda1, SEXP retPath, SEXP maxSegs, SEXP segmentVec, SEXP primBds) { int segmented_ret = (segmentVec != R_NilValue) ? 1 : 0; int max_segs = GetInt(maxSegs, 0, 0); double * all_obs = REAL(obsSeq); int n_obs = LENGTH(obsSeq); int n_protect = 0; double * back_ptrs = AllocProtectReal(2*n_obs); n_protect++; int * fused_segs1 = NULL; int * fused_segs2 = NULL; double *o2 = NULL, *wts2 = NULL, *o3 = NULL, *wts3 = NULL; int msg_buf_len = FL_SEGSZ*2*30; double * msg_buf = malloc( msg_buf_len*sizeof(double) ); SEXP ret_sxp; PROTECT(ret_sxp = NEW_INTEGER(1)); n_protect++; double obs_min = R_PosInf, obs_max = R_NegInf; for(int i = 0; i < n_obs; i++){ if(R_FINITE(all_obs[i])){ if(all_obs[i] < obs_min) obs_min = all_obs[i]; if(all_obs[i] > obs_max) obs_max = all_obs[i]; } } double lam1 = GetNumeric(lambda1, 0, 0); int n_lam2 = LENGTH(lambda2); int n_o = n_obs; double * o = all_obs; double * wts = NULL; double * prim_bds = (primBds == R_NilValue) ? NULL : REAL(primBds); for(int lam2i = 0; lam2i < n_lam2; lam2i++){ double lam2 = REAL(lambda2)[lam2i]; double beta_hat = 0.0; int r1 = L2L1VitFwd(lam2, o, wts, &msg_buf, &msg_buf_len, max_segs, back_ptrs, NULL, n_o, max_segs, obs_min, obs_max, &beta_hat); if(r1 != 1){ INTEGER(ret_sxp)[0] = r1; UNPROTECT(n_protect); return ret_sxp; } int * fs = fused_segs1; int nfsd2 = 0; if(o2 == NULL || segmented_ret){ //We haven't allocated the buffers for the //fused observations yet nfsd2 = L2L1GetNFused(beta_hat, n_o, back_ptrs); o2 = AllocProtectReal(nfsd2); n_protect++; wts2 = AllocProtectReal(nfsd2); n_protect++; fused_segs1 = AllocProtectInt(2*(nfsd2+1)); n_protect++; fused_segs2 = AllocProtectInt(2*(nfsd2+1)); n_protect++; } double * fit_v = NULL; if(segmented_ret){ SEXP tmp_sxp; PROTECT(tmp_sxp = NEW_NUMERIC(nfsd2)); SET_VECTOR_ELT(retPath, lam2i, tmp_sxp); UNPROTECT(1); fit_v = REAL(VECTOR_ELT(retPath, lam2i)); }else{ fit_v = REAL(retPath) + n_obs * lam2i; } int seg_R = (fs) ? fs[0] : (n_obs-1); int seg_L = (fs) ? fs[1] : (n_obs-1); int n_fused2 = 0; fused_segs2[0] = seg_R; if(fs) fs += 2; double bd1 = 0.0, bd2 = 0.0; double beta_hat_shr = beta_hat; if(segmented_ret){ fit_v[(nfsd2-1) - n_fused2] = beta_hat_shr; bd1 += fabs(beta_hat_shr); }else{ for(int k = seg_L; k <= seg_R; k++){ fit_v[k] = beta_hat_shr; } bd1 += fabs(beta_hat_shr) * (double)(1+seg_R - seg_L); } if( !R_FINITE(o[n_o-1]) ){ o2[n_fused2] = wts2[n_fused2] = 0; }else if(wts){ o2[n_fused2] = o[n_o-1]*wts[n_o-1]; wts2[n_fused2] = wts[n_o-1]; }else{ o2[n_fused2] = o[n_o-1]; wts2[n_fused2] = 1.0; } if(n_o == 1){ n_fused2 = 1; fused_segs2[0] = n_obs - 1; fused_segs2[1] = 0; o2[0] = o[0] * wts[0]; wts2[0] = wts[0]; } for(int i = n_o-2; i >= 0; i--){ seg_R = (fs) ? fs[0] : i; seg_L = (fs) ? fs[1] : i; double * bp = back_ptrs + (2*(i+1)); if(beta_hat > bp[1]){ bd2 += fabs(beta_hat - bp[1]); beta_hat = bp[1]; beta_hat_shr = beta_hat; fused_segs2[2*n_fused2 + 1] = seg_R+1; n_fused2++; o2[n_fused2] = wts2[n_fused2] = 0.0; fused_segs2[2*n_fused2] = seg_R; }else if(beta_hat < bp[0]){ bd2 += fabs(beta_hat - bp[0]); beta_hat = bp[0]; beta_hat_shr = beta_hat; fused_segs2[2*n_fused2 + 1] = seg_R+1; n_fused2++; o2[n_fused2] = wts2[n_fused2] = 0.0; fused_segs2[2*n_fused2] = seg_R; } if(R_FINITE(o[i])){ if(wts){ o2[n_fused2] += o[i]*wts[i]; wts2[n_fused2] += wts[i]; }else{ o2[n_fused2] += o[i]; wts2[n_fused2] += 1.0; } } if(segmented_ret){ fit_v[(nfsd2-1) - n_fused2] = beta_hat_shr; }else{ for(int k = seg_L; k <= seg_R; k++){ fit_v[k] = beta_hat_shr; } } bd1 += fabs(beta_hat_shr) * (double)(1+seg_R - seg_L); if(i == 0){ fused_segs2[2*n_fused2 + 1] = seg_L; n_fused2++; } if(fs) fs += 2; } if(prim_bds){ double * bdv = prim_bds + 2*lam2i; bdv[0] = bd1; bdv[1] = bd2; } // We have stored the fitted parameters. Now we collapse // observations and fit on the new sequence at the next // iteration obs_min = R_PosInf; obs_max = R_NegInf; if(o3 == NULL){ o3 = AllocProtectReal(n_fused2); n_protect++; wts3 = AllocProtectReal(n_fused2); n_protect++; } for(int i = 0; i < n_fused2; i++){ if( wts2[n_fused2-1-i] > 0.0 ){ double z = o2[n_fused2-1-i] / wts2[n_fused2-1-i]; if(z < obs_min) obs_min = z; if(z > obs_max) obs_max = z; o3[i] = z; }else{ o3[i] = NA_REAL; } wts3[i] = wts2[n_fused2-1-i]; } if(n_o == 1){ obs_max = obs_min + FL_ENDPT_KNOT_FUDGE; obs_min -= FL_ENDPT_KNOT_FUDGE; } if(segmented_ret){ SEXP tmp_sxp, seg_dim; PROTECT(tmp_sxp = NEW_INTEGER(2*nfsd2)); PROTECT(seg_dim=NEW_INTEGER(2)); INTEGER(seg_dim)[0] = 2; INTEGER(seg_dim)[1] = nfsd2; SET_DIM(tmp_sxp,seg_dim); SET_VECTOR_ELT(segmentVec, lam2i, tmp_sxp); UNPROTECT(2); int * seg_v = INTEGER(VECTOR_ELT(segmentVec, lam2i)); for(int k = 0; k < nfsd2; k++){ seg_v[1+2*k] = fused_segs2[(nfsd2-1-k)*2]+1; seg_v[2*k] = fused_segs2[1+(nfsd2-1-k)*2]+1; } } o = o3; wts = wts3; fs = fused_segs2; fused_segs2 = fused_segs1; fused_segs1 = fs; n_o = n_fused2; } free(msg_buf); if(segmented_ret){ for(int lam2i = 0; lam2i < n_lam2; lam2i++){ double * bv = REAL(VECTOR_ELT(retPath, lam2i)); int m = LENGTH(VECTOR_ELT(retPath, lam2i)); for(int i = 0; i < m; i++){ bv[i] = soft_thresh(bv[i], lam1); } } }else{ double * bv = REAL(retPath); int m = LENGTH(retPath); for(int i = 0; i < m; i++){ bv[i] = soft_thresh(bv[i], lam1); } } INTEGER(ret_sxp)[0] = 1; UNPROTECT(n_protect); return ret_sxp; }
SEXP fastcluster(SEXP const N_, SEXP const method_, SEXP D_, SEXP members_) { SEXP r = NULL; // return value try{ /* Input checks */ // Parameter N: number of data points PROTECT(N_); if (!IS_INTEGER(N_) || LENGTH(N_)!=1) Rf_error("'N' must be a single integer."); const int N = *INTEGER_POINTER(N_); if (N<2) Rf_error("N must be at least 2."); const std::ptrdiff_t NN = static_cast<std::ptrdiff_t>(N)*(N-1)/2; UNPROTECT(1); // N_ // Parameter method: dissimilarity index update method PROTECT(method_); if (!IS_INTEGER(method_) || LENGTH(method_)!=1) Rf_error("'method' must be a single integer."); const int method = *INTEGER_POINTER(method_) - 1; // index-0 based; if (method<METHOD_METR_SINGLE || method>METHOD_METR_MEDIAN) { Rf_error("Invalid method index."); } UNPROTECT(1); // method_ // Parameter members: number of members in each node auto_array_ptr<t_float> members; if (method==METHOD_METR_AVERAGE || method==METHOD_METR_WARD || method==METHOD_METR_CENTROID) { members.init(N); if (Rf_isNull(members_)) { for (t_index i=0; i<N; ++i) members[i] = 1; } else { PROTECT(members_ = AS_NUMERIC(members_)); if (LENGTH(members_)!=N) Rf_error("'members' must have length N."); const t_float * const m = NUMERIC_POINTER(members_); for (t_index i=0; i<N; ++i) members[i] = m[i]; UNPROTECT(1); // members } } // Parameter D_: dissimilarity matrix PROTECT(D_ = AS_NUMERIC(D_)); if (LENGTH(D_)!=NN) Rf_error("'D' must have length (N \\choose 2)."); const double * const D = NUMERIC_POINTER(D_); // Make a working copy of the dissimilarity array // for all methods except "single". auto_array_ptr<double> D__; if (method!=METHOD_METR_SINGLE) { D__.init(NN); for (std::ptrdiff_t i=0; i<NN; ++i) D__[i] = D[i]; } UNPROTECT(1); // D_ /* Clustering step */ cluster_result Z2(N-1); switch (method) { case METHOD_METR_SINGLE: MST_linkage_core(N, D, Z2); break; case METHOD_METR_COMPLETE: NN_chain_core<METHOD_METR_COMPLETE, t_float>(N, D__, NULL, Z2); break; case METHOD_METR_AVERAGE: NN_chain_core<METHOD_METR_AVERAGE, t_float>(N, D__, members, Z2); break; case METHOD_METR_WEIGHTED: NN_chain_core<METHOD_METR_WEIGHTED, t_float>(N, D__, NULL, Z2); break; case METHOD_METR_WARD: NN_chain_core<METHOD_METR_WARD, t_float>(N, D__, members, Z2); break; case METHOD_METR_CENTROID: generic_linkage<METHOD_METR_CENTROID, t_float>(N, D__, members, Z2); break; case METHOD_METR_MEDIAN: generic_linkage<METHOD_METR_MEDIAN, t_float>(N, D__, NULL, Z2); break; default: throw std::runtime_error(std::string("Invalid method.")); } D__.free(); // Free the memory now members.free(); // (not strictly necessary). SEXP m; // return field "merge" PROTECT(m = NEW_INTEGER(2*(N-1))); int * const merge = INTEGER_POINTER(m); SEXP dim_m; // Specify that m is an (N-1)×2 matrix PROTECT(dim_m = NEW_INTEGER(2)); INTEGER(dim_m)[0] = N-1; INTEGER(dim_m)[1] = 2; SET_DIM(m, dim_m); SEXP h; // return field "height" PROTECT(h = NEW_NUMERIC(N-1)); double * const height = NUMERIC_POINTER(h); SEXP o; // return fiels "order' PROTECT(o = NEW_INTEGER(N)); int * const order = INTEGER_POINTER(o); if (method==METHOD_METR_CENTROID || method==METHOD_METR_MEDIAN) generate_R_dendrogram<true>(merge, height, order, Z2, N); else generate_R_dendrogram<false>(merge, height, order, Z2, N); SEXP n; // names PROTECT(n = NEW_CHARACTER(3)); SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge")); SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height")); SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order")); PROTECT(r = NEW_LIST(3)); // field names in the output list SET_ELEMENT(r, 0, m); SET_ELEMENT(r, 1, h); SET_ELEMENT(r, 2, o); SET_NAMES(r, n); UNPROTECT(6); // m, dim_m, h, o, r, n } // try catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } #ifdef FE_INVALID catch(const fenv_error&){ Rf_error( "NaN dissimilarity value in intermediate results."); } #endif catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return r; }
SEXP fastcluster_vector(SEXP const method_, SEXP const metric_, SEXP X_, SEXP members_, SEXP p_) { SEXP r = NULL; // return value try{ /* Input checks */ // Parameter method: dissimilarity index update method PROTECT(method_); if (!IS_INTEGER(method_) || LENGTH(method_)!=1) Rf_error("'method' must be a single integer."); int method = *INTEGER_POINTER(method_) - 1; // index-0 based; if (method<METHOD_VECTOR_SINGLE || method>METHOD_VECTOR_MEDIAN) { Rf_error("Invalid method index."); } UNPROTECT(1); // method_ // Parameter metric PROTECT(metric_); if (!IS_INTEGER(metric_) || LENGTH(metric_)!=1) Rf_error("'metric' must be a single integer."); int metric = *INTEGER_POINTER(metric_) - 1; // index-0 based; if (metric<0 || metric>5 || (method!=METHOD_VECTOR_SINGLE && metric!=0) ) { Rf_error("Invalid metric index."); } UNPROTECT(1); // metric_ // data array PROTECT(X_ = AS_NUMERIC(X_)); SEXP dims_ = PROTECT( Rf_getAttrib( X_, R_DimSymbol ) ) ; if( dims_ == R_NilValue || LENGTH(dims_) != 2 ) { Rf_error( "Argument is not a matrix."); } const int * const dims = INTEGER(dims_); const int N = dims[0]; const int dim = dims[1]; if (N<2) Rf_error("There must be at least two data points."); // Make a working copy of the dissimilarity array // for all methods except "single". double * X__ = NUMERIC_POINTER(X_); // Copy the input array and change it from Fortran-contiguous style // to C-contiguous style // (Waste of memory for 'single'; the other methods need a copy auto_array_ptr<double> X(LENGTH(X_)); for (std::ptrdiff_t i=0; i<N; ++i) for (std::ptrdiff_t j=0; j<dim; ++j) X[i*dim+j] = X__[i+j*N]; UNPROTECT(2); // dims_, X_ // Parameter members: number of members in each node auto_array_ptr<t_float> members; if (method==METHOD_VECTOR_WARD || method==METHOD_VECTOR_CENTROID) { members.init(N); if (Rf_isNull(members_)) { for (t_index i=0; i<N; ++i) members[i] = 1; } else { PROTECT(members_ = AS_NUMERIC(members_)); if (LENGTH(members_)!=N) Rf_error("The length of 'members' must be the same as the number of data points."); const t_float * const m = NUMERIC_POINTER(members_); for (t_index i=0; i<N; ++i) members[i] = m[i]; UNPROTECT(1); // members } } // Parameter p PROTECT(p_); double p = 0; if (metric==METRIC_R_MINKOWSKI) { if (!IS_NUMERIC(p_) || LENGTH(p_)!=1) Rf_error("'p' must be a single floating point number."); p = *NUMERIC_POINTER(p_); } else { if (p_ != R_NilValue) { Rf_error("No metric except 'minkowski' allows a 'p' parameter."); } } UNPROTECT(1); // p_ /* The generic_linkage_vector_alternative algorithm uses labels N,N+1,... for the new nodes, so we need a table which node is stored in which row. Instructions: Set this variable to true for all methods which use the generic_linkage_vector_alternative algorithm below. */ bool make_row_repr = (method==METHOD_VECTOR_CENTROID || method==METHOD_VECTOR_MEDIAN); R_dissimilarity dist(X, N, dim, members, static_cast<unsigned char>(method), static_cast<unsigned char>(metric), p, make_row_repr); cluster_result Z2(N-1); /* Clustering step */ switch (method) { case METHOD_VECTOR_SINGLE: MST_linkage_core_vector(N, dist, Z2); break; case METHOD_VECTOR_WARD: generic_linkage_vector<METHOD_METR_WARD>(N, dist, Z2); break; case METHOD_VECTOR_CENTROID: generic_linkage_vector_alternative<METHOD_METR_CENTROID>(N, dist, Z2); break; case METHOD_VECTOR_MEDIAN: generic_linkage_vector_alternative<METHOD_METR_MEDIAN>(N, dist, Z2); break; default: throw std::runtime_error(std::string("Invalid method.")); } X.free(); // Free the memory now members.free(); // (not strictly necessary). dist.postprocess(Z2); SEXP m; // return field "merge" PROTECT(m = NEW_INTEGER(2*(N-1))); int * const merge = INTEGER_POINTER(m); SEXP dim_m; // Specify that m is an (N-1)×2 matrix PROTECT(dim_m = NEW_INTEGER(2)); INTEGER(dim_m)[0] = N-1; INTEGER(dim_m)[1] = 2; SET_DIM(m, dim_m); SEXP h; // return field "height" PROTECT(h = NEW_NUMERIC(N-1)); double * const height = NUMERIC_POINTER(h); SEXP o; // return fiels "order' PROTECT(o = NEW_INTEGER(N)); int * const order = INTEGER_POINTER(o); if (method==METHOD_VECTOR_SINGLE) generate_R_dendrogram<false>(merge, height, order, Z2, N); else generate_R_dendrogram<true>(merge, height, order, Z2, N); SEXP n; // names PROTECT(n = NEW_CHARACTER(3)); SET_STRING_ELT(n, 0, COPY_TO_USER_STRING("merge")); SET_STRING_ELT(n, 1, COPY_TO_USER_STRING("height")); SET_STRING_ELT(n, 2, COPY_TO_USER_STRING("order")); PROTECT(r = NEW_LIST(3)); // field names in the output list SET_ELEMENT(r, 0, m); SET_ELEMENT(r, 1, h); SET_ELEMENT(r, 2, o); SET_NAMES(r, n); UNPROTECT(6); // m, dim_m, h, o, r, n } // try catch (const std::bad_alloc&) { Rf_error( "Memory overflow."); } catch(const std::exception& e){ Rf_error( e.what() ); } catch(const nan_error&){ Rf_error("NaN dissimilarity value."); } catch(...){ Rf_error( "C++ exception (unknown reason)." ); } return r; }
/* Increase or decrease box size by a radius in at least n dimensions. */ Datum cube_enlarge(PG_FUNCTION_ARGS) { NDBOX *a = PG_GETARG_NDBOX(0); double r = PG_GETARG_FLOAT8(1); int32 n = PG_GETARG_INT32(2); NDBOX *result; int dim = 0; int size; int i, j; if (n > CUBE_MAX_DIM) n = CUBE_MAX_DIM; if (r > 0 && n > 0) dim = n; if (DIM(a) > dim) dim = DIM(a); size = CUBE_SIZE(dim); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, dim); for (i = 0, j = dim; i < DIM(a); i++, j++) { if (LL_COORD(a, i) >= UR_COORD(a, i)) { result->x[i] = UR_COORD(a, i) - r; result->x[j] = LL_COORD(a, i) + r; } else { result->x[i] = LL_COORD(a, i) - r; result->x[j] = UR_COORD(a, i) + r; } if (result->x[i] > result->x[j]) { result->x[i] = (result->x[i] + result->x[j]) / 2; result->x[j] = result->x[i]; } } /* dim > a->dim only if r > 0 */ for (; i < dim; i++, j++) { result->x[i] = -r; result->x[j] = r; } /* * Check if the result was in fact a point, and set the flag in the datum * accordingly. (we don't bother to repalloc it smaller) */ if (cube_is_point_internal(result)) { size = POINT_SIZE(dim); SET_VARSIZE(result, size); SET_POINT_BIT(result); } PG_FREE_IF_COPY(a, 0); PG_RETURN_NDBOX(result); }
/* * Public */ SEXP do_mrdwt(SEXP vntX, SEXP vntH, SEXP vntL) { SEXP vntOut; SEXP vntYl; SEXP vntYh; SEXP vntLr; double *x, *h, *yl, *yh; int m, n, lh, L; #ifdef DEBUG_RWT REprintf("In do_mrdwt(x, h, L)...\n"); #endif /* * Handle first parameter (numeric matrix) */ #ifdef DEBUG_RWT REprintf("\tfirst param 'x'\n"); #endif if (GetMatrixDimen(vntX, &m, &n) != 2) { error("'x' is not a two dimensional matrix"); /*NOTREACHED*/ } PROTECT(vntX = AS_NUMERIC(vntX)); x = NUMERIC_POINTER(vntX); #ifdef DEBUG_RWT REprintf("x[%d][%d] = 0x%p\n", m, n, x); #endif /* * Handle second parameter (numeric vector) */ #ifdef DEBUG_RWT REprintf("\tsecond param 'h'\n"); #endif PROTECT(vntH = AS_NUMERIC(vntH)); h = NUMERIC_POINTER(vntH); lh = GET_LENGTH(vntH); #ifdef DEBUG_RWT REprintf("h[%d] = 0x%p\n", GET_LENGTH(vntH), h); #endif /* * Handle third parameter (integer scalar) */ #ifdef DEBUG_RWT REprintf("\tthird param 'L'\n"); #endif { PROTECT(vntL = AS_INTEGER(vntL)); { int *piL = INTEGER_POINTER(vntL); L = piL[0]; } UNPROTECT(1); } #ifdef DEBUG_RWT REprintf("L = %d\n", L); #endif #ifdef DEBUG_RWT REprintf("\tcheck number of levels\n"); #endif if (L < 0) { error("The number of levels, L, must be a non-negative integer"); /*NOTREACHED*/ } #ifdef DEBUG_RWT REprintf("\tcheck dimen prereqs\n"); #endif /* Check the ROW dimension of input */ if (m > 1) { double mtest = (double) m / pow(2.0, (double) L); if (!isint(mtest)) { error("The matrix row dimension must be of size m*2^(L)"); /*NOTREACHED*/ } } /* Check the COLUMN dimension of input */ if (n > 1) { double ntest = (double) n / pow(2.0, (double) L); if (!isint(ntest)) { error("The matrix column dimension must be of size n*2^(L)"); /*NOTREACHED*/ } } #ifdef DEBUG_RWT REprintf("\tcreating value objects\n"); #endif /* Create yl value object */ { #ifdef DEBUG_RWT REprintf("\tcreating 'yl' value object\n"); #endif PROTECT(vntYl = NEW_NUMERIC(m*n)); yl = NUMERIC_POINTER(vntYl); /* Add dimension attribute to value object */ #ifdef DEBUG_RWT REprintf("\tconvert 'yl' value object to matrix\n"); #endif { SEXP vntDim; PROTECT(vntDim = NEW_INTEGER(2)); INTEGER(vntDim)[0] = m; INTEGER(vntDim)[1] = n; SET_DIM(vntYl, vntDim); UNPROTECT(1); } } /* Create yh value object */ { int cols = (min(m,n) == 1) ? (L * n) : (3 * L * n); #ifdef DEBUG_RWT REprintf("\tcreating 'yh' value object\n"); #endif PROTECT(vntYh = NEW_NUMERIC(m*cols)); yh = NUMERIC_POINTER(vntYh); /* Add dimension attribute to value object */ #ifdef DEBUG_RWT REprintf("\tconvert 'yh' value object to matrix\n"); #endif { SEXP vntDim; PROTECT(vntDim = NEW_INTEGER(2)); INTEGER(vntDim)[0] = m; INTEGER(vntDim)[1] = cols; SET_DIM(vntYh, vntDim); UNPROTECT(1); } } /* Create Lr value object */ { #ifdef DEBUG_RWT REprintf("\tcreating 'Lr' value object\n"); #endif PROTECT(vntLr = NEW_INTEGER(1)); INTEGER_POINTER(vntLr)[0] = L; } #ifdef DEBUG_RWT REprintf("\tcompute redundant discrete wavelet transform\n"); #endif MRDWT(x, m, n, h, lh, L, yl, yh); /* Unprotect params */ UNPROTECT(2); #ifdef DEBUG_RWT REprintf("\tcreate list output object\n"); #endif PROTECT(vntOut = NEW_LIST(3)); #ifdef DEBUG_RWT REprintf("\tassigning value objects to list\n"); #endif SET_VECTOR_ELT(vntOut, 0, vntYl); SET_VECTOR_ELT(vntOut, 1, vntYh); SET_VECTOR_ELT(vntOut, 2, vntLr); /* Unprotect value objects */ UNPROTECT(3); { SEXP vntNames; #ifdef DEBUG_RWT REprintf("\tassigning names to value objects in list\n"); #endif PROTECT(vntNames = NEW_CHARACTER(3)); SET_STRING_ELT(vntNames, 0, CREATE_STRING_VECTOR("yl")); SET_STRING_ELT(vntNames, 1, CREATE_STRING_VECTOR("yh")); SET_STRING_ELT(vntNames, 2, CREATE_STRING_VECTOR("L")); SET_NAMES(vntOut, vntNames); UNPROTECT(1); } /* Unprotect output object */ UNPROTECT(1); #ifdef DEBUG_RWT REprintf("\treturning output...\n"); #endif return vntOut; }
/* ** Allows the construction of a cube from 2 float[]'s */ Datum cube_a_f8_f8(PG_FUNCTION_ARGS) { ArrayType *ur = PG_GETARG_ARRAYTYPE_P(0); ArrayType *ll = PG_GETARG_ARRAYTYPE_P(1); NDBOX *result; int i; int dim; int size; bool point; double *dur, *dll; if (array_contains_nulls(ur) || array_contains_nulls(ll)) ereport(ERROR, (errcode(ERRCODE_ARRAY_ELEMENT_ERROR), errmsg("cannot work with arrays containing NULLs"))); dim = ARRNELEMS(ur); if (dim > CUBE_MAX_DIM) ereport(ERROR, (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED), errmsg("can't extend cube"), errdetail("A cube cannot have more than %d dimensions.", CUBE_MAX_DIM))); if (ARRNELEMS(ll) != dim) ereport(ERROR, (errcode(ERRCODE_ARRAY_ELEMENT_ERROR), errmsg("UR and LL arrays must be of same length"))); dur = ARRPTR(ur); dll = ARRPTR(ll); /* Check if it's a point */ point = true; for (i = 0; i < dim; i++) { if (dur[i] != dll[i]) { point = false; break; } } size = point ? POINT_SIZE(dim) : CUBE_SIZE(dim); result = (NDBOX *) palloc0(size); SET_VARSIZE(result, size); SET_DIM(result, dim); for (i = 0; i < dim; i++) result->x[i] = dur[i]; if (!point) { for (i = 0; i < dim; i++) result->x[i + dim] = dll[i]; } else SET_POINT_BIT(result); PG_RETURN_NDBOX(result); }