示例#1
0
文件: cube.c 项目: adam8157/gpdb
/* 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);
}
示例#2
0
文件: cube.c 项目: adam8157/gpdb
/* 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);
}
示例#3
0
文件: misc.cpp 项目: rforge/corbi
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);
}
示例#4
0
文件: misc.cpp 项目: rforge/corbi
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);
}
示例#5
0
文件: cube.c 项目: adam8157/gpdb
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);
}
示例#6
0
文件: cube.c 项目: adam8157/gpdb
/* 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);
}
示例#7
0
文件: util.c 项目: czarrar/niftir
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;
}
示例#8
0
// 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;
}
示例#10
0
文件: coding.c 项目: cran/cba
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;
}
示例#11
0
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;
}
示例#12
0
文件: cube.c 项目: adam8157/gpdb
/*
** 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);
}
示例#13
0
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;
}
示例#14
0
// 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);
}
示例#15
0
文件: pfilter2.c 项目: nxdao2000/pis2
// 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);
}
示例#16
0
文件: cube.c 项目: adam8157/gpdb
/* 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);
}
示例#17
0
文件: cube.c 项目: adam8157/gpdb
/* 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);
}
示例#18
0
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;
  }
示例#21
0
文件: cube.c 项目: adam8157/gpdb
/* 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);
}
示例#22
0
文件: do_mrdwt.c 项目: cran/rwt
/*
 * 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;
}
示例#23
0
文件: cube.c 项目: adam8157/gpdb
/*
** 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);
}