/* 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);
}