示例#1
0
SEXP minc2_apply(SEXP filenames, SEXP fn, SEXP have_mask, 
		 SEXP mask, SEXP mask_value, SEXP rho) {
  int                result;
  mihandle_t         *hvol, hmask;
  int                i, v0, v1, v2, output_index, buffer_index;
  unsigned long     start[3], count[3];
  //unsigned long      location[3];
  int                num_files;
  double             *xbuffer, *xoutput, **full_buffer;
  double             *xhave_mask, *xmask_value;
  double             *mask_buffer;
  midimhandle_t      dimensions[3];
  misize_t            sizes[3];
  SEXP               output, buffer;
  //SEXP               R_fcall;
  

  /* allocate memory for volume handles */
  num_files = LENGTH(filenames);
  hvol = malloc(num_files * sizeof(mihandle_t));

  Rprintf("Number of volumes: %i\n", num_files);

  /* open the mask - if so desired */
  xhave_mask = REAL(have_mask);
  if (xhave_mask[0] == 1) {
    result = miopen_volume(CHAR(STRING_ELT(mask, 0)),
			   MI2_OPEN_READ, &hmask);
    if (result != MI_NOERROR) {
      error("Error opening mask: %s.\n", CHAR(STRING_ELT(mask, 0)));
    }
  }
  
  /* get the value inside that mask */
  xmask_value = REAL(mask_value);

  /* open each volume */
  for(i=0; i < num_files; i++) {
    result = miopen_volume(CHAR(STRING_ELT(filenames, i)),
      MI2_OPEN_READ, &hvol[i]);
    if (result != MI_NOERROR) {
      error("Error opening input file: %s.\n", CHAR(STRING_ELT(filenames,i)));
    }
  }

  /* get the file dimensions and their sizes - assume they are the same*/
  miget_volume_dimensions( hvol[0], MI_DIMCLASS_SPATIAL,
			   MI_DIMATTR_ALL, MI_DIMORDER_FILE,
			   3, dimensions);
  result = miget_dimension_sizes( dimensions, 3, sizes );
  Rprintf("Volume sizes: %i %i %i\n", sizes[0], sizes[1], sizes[2]);

  /* allocate the output buffer */
  PROTECT(output=allocVector(REALSXP, (sizes[0] * sizes[1] * sizes[2])));
  xoutput = REAL(output);

  /* allocate the local buffer that will be passed to the function */
  PROTECT(buffer=allocVector(REALSXP, num_files));
  xbuffer = REAL(buffer); 

  //PROTECT(R_fcall = lang2(fn, R_NilValue));


  /* allocate first dimension of the buffer */
  full_buffer = malloc(num_files * sizeof(double));

  /* allocate second dimension of the buffer 
     - big enough to hold one slice per subject at a time */
  for (i=0; i < num_files; i++) {
    full_buffer[i] = malloc(sizes[1] * sizes[2] * sizeof(double));
  }
  
  /* allocate buffer for mask - if necessary */
  if (xhave_mask[0] == 1) {
    mask_buffer = malloc(sizes[1] * sizes[2] * sizeof(double));
  }
	
  /* set start and count. start[0] will change during the loop */
  start[0] = 0; start[1] = 0; start[2] = 0;
  count[0] = 1; count[1] = sizes[1]; count[2] = sizes[2];

  /* loop across all files and voxels */
  Rprintf("In slice \n");
  for (v0=0; v0 < sizes[0]; v0++) {
    start[0] = v0;
    for (i=0; i < num_files; i++) {
      if (miget_real_value_hyperslab(hvol[i], 
				     MI_TYPE_DOUBLE, 
				     (misize_t *) start, 
				     (misize_t *) count, 
				     full_buffer[i]) )
	error("Error opening buffer.\n");
    }
    /* get mask - if desired */
    if (xhave_mask[0] == 1) {
      if (miget_real_value_hyperslab(hmask, 
				     MI_TYPE_DOUBLE, 
				     (misize_t *) start, 
				     (misize_t *) count, 
				     mask_buffer) )
	error("Error opening mask buffer.\n");
    }

    Rprintf(" %d ", v0);
    for (v1=0; v1 < sizes[1]; v1++) {
      for (v2=0; v2 < sizes[2]; v2++) {
	output_index = v0*sizes[1]*sizes[2]+v1*sizes[2]+v2;
	buffer_index = sizes[2] * v1 + v2;

	/* only perform operation if not masked */
	if(xhave_mask[0] == 0 
	   || (xhave_mask[0] == 1 && 
	       mask_buffer[buffer_index] > xmask_value[0] -0.5 &&
	       mask_buffer[buffer_index] < xmask_value[0] + 0.5)) {
	
	  for (i=0; i < num_files; i++) {
// 	    location[0] = v0;
// 	    location[1] = v1;
// 	    location[2] = v2;
	    //SET_VECTOR_ELT(buffer, i, full_buffer[i][index]);
	    //result = miget_real_value(hvol[i], location, 3, &xbuffer[i]);
	    xbuffer[i] = full_buffer[i][buffer_index];
	    
	    //Rprintf("V%i: %f\n", i, full_buffer[i][index]);

	  }
	  /* install the variable "x" into environment */
	  defineVar(install("x"), buffer, rho);
	  //SETCADDR(R_fcall, buffer);
	  //SET_VECTOR_ELT(output, index, eval(R_fcall, rho));
	  //SET_VECTOR_ELT(output, index, test);
	  /* evaluate the function */
	  xoutput[output_index] = REAL(eval(fn, rho))[0]; 
	}
	else {
	  xoutput[output_index] = 0;
	}
      }
    }
  }
  Rprintf("\nDone\n");

  /* free memory */
  for (i=0; i<num_files; i++) {
    miclose_volume(hvol[i]);
    free(full_buffer[i]);
  }
  free(full_buffer);
  UNPROTECT(2);

  /* return the results */
  return(output);
}
示例#2
0
static void fmingr(int n, double *p, double *df, void *ex)
{
    SEXP s, x;
    int i;
    double val1, val2, eps, epsused, tmp;
    OptStruct OS = (OptStruct) ex;
    PROTECT_INDEX ipx;

    if (!isNull(OS->R_gcall)) { /* analytical derivatives */
	PROTECT(x = allocVector(REALSXP, n));
	if(!isNull(OS->names)) setAttrib(x, R_NamesSymbol, OS->names);
	for (i = 0; i < n; i++) {
	    if (!R_FINITE(p[i]))
		error(_("non-finite value supplied by optim"));
	    REAL(x)[i] = p[i] * (OS->parscale[i]);
	}
	SETCADR(OS->R_gcall, x);
	PROTECT_WITH_INDEX(s = eval(OS->R_gcall, OS->R_env), &ipx);
	REPROTECT(s = coerceVector(s, REALSXP), ipx);
	if(LENGTH(s) != n)
	    error(_("gradient in optim evaluated to length %d not %d"),
		  LENGTH(s), n);
	for (i = 0; i < n; i++)
	    df[i] = REAL(s)[i] * (OS->parscale[i])/(OS->fnscale);
	UNPROTECT(2);
    } else { /* numerical derivatives */
	PROTECT(x = allocVector(REALSXP, n));
	setAttrib(x, R_NamesSymbol, OS->names);
	SET_NAMED(x, 2); // in case f tries to change it
	for (i = 0; i < n; i++) REAL(x)[i] = p[i] * (OS->parscale[i]);
	SETCADR(OS->R_fcall, x);
	if(OS->usebounds == 0) {
	    for (i = 0; i < n; i++) {
		eps = OS->ndeps[i];
		REAL(x)[i] = (p[i] + eps) * (OS->parscale[i]);
		PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx);
		REPROTECT(s = coerceVector(s, REALSXP), ipx);
		val1 = REAL(s)[0]/(OS->fnscale);
		REAL(x)[i] = (p[i] - eps) * (OS->parscale[i]);
		REPROTECT(s = eval(OS->R_fcall, OS->R_env), ipx);
		REPROTECT(s = coerceVector(s, REALSXP), ipx);
		val2 = REAL(s)[0]/(OS->fnscale);
		df[i] = (val1 - val2)/(2 * eps);
		if(!R_FINITE(df[i]))
		    error(("non-finite finite-difference value [%d]"), i+1);
		REAL(x)[i] = p[i] * (OS->parscale[i]);
		UNPROTECT(1);
	    }
	} else { /* usebounds */
	    for (i = 0; i < n; i++) {
		epsused = eps = OS->ndeps[i];
		tmp = p[i] + eps;
		if (tmp > OS->upper[i]) {
		    tmp = OS->upper[i];
		    epsused = tmp - p[i];
		}
		REAL(x)[i] = tmp * (OS->parscale[i]);
		PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx);
		REPROTECT(s = coerceVector(s, REALSXP), ipx);
		val1 = REAL(s)[0]/(OS->fnscale);
		tmp = p[i] - eps;
		if (tmp < OS->lower[i]) {
		    tmp = OS->lower[i];
		    eps = p[i] - tmp;
		}
		REAL(x)[i] = tmp * (OS->parscale[i]);
		REPROTECT(s = eval(OS->R_fcall, OS->R_env), ipx);
		REPROTECT(s = coerceVector(s, REALSXP), ipx);
		val2 = REAL(s)[0]/(OS->fnscale);
		df[i] = (val1 - val2)/(epsused + eps);
		if(!R_FINITE(df[i]))
		    error(("non-finite finite-difference value [%d]"), i+1);
		REAL(x)[i] = p[i] * (OS->parscale[i]);
		UNPROTECT(1);
	    }
	}
	UNPROTECT(1); /* x */
    }
}
示例#3
0
文件: Grid-R.c 项目: rocanale/RElem
SEXP gridLCM( SEXP Rptr){
  SEXP ans= PROTECT( allocVector(INTSXP,1) );
  ElGridLCM( toGrid(Rptr), INTEGER(ans) );
  UNPROTECT(1);
  return ans;
}
示例#4
0
文件: RArcInfo.c 项目: cran/RArcInfo
SEXP get_txt_data(SEXP directory, SEXP coverage, SEXP filename) 
{
	int i,j,n;
	int **idata;
	double *x, *y;
	char pathtofile[PATH];
	AVCTxt *reg;
	AVCBinFile *file;
	SEXP *table, points,aux;


	strcpy(pathtofile, CHAR(STRING_ELT(directory,0)));
	complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)), 1);/*FIXME*/

	if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileTXT)))
		error("Error opening file");

	n=0;

	while(AVCBinReadNextTxt(file)){n++;}

	Rprintf("Number of TxT ANNOTATIONS:%d\n",n);


	table=calloc(6, sizeof(SEXP));
	idata=calloc(5, sizeof(int *));


	PROTECT(table[0]=NEW_INTEGER(n));/*nTxtId*/
	idata[0]=INTEGER(table[0]);
	PROTECT(table[1]=NEW_INTEGER(n));/*nUserId*/
	idata[1]=INTEGER(table[1]);
	PROTECT(table[2]=NEW_INTEGER(n));/*nLevel*/
	idata[2]=INTEGER(table[2]);
	PROTECT(table[3]=NEW_INTEGER(n));/*numVerticesLine*/
	idata[3]=INTEGER(table[3]);
	PROTECT(table[4]=NEW_INTEGER(n));/*numVerticesArrow*/
	idata[4]=INTEGER(table[4]);

	PROTECT(table[5]=NEW_STRING(n));/*Character strings*/


	PROTECT(points=NEW_LIST(n));

	if(AVCBinReadRewind(file))
		error("Rewind");

	for(i=0;i<n;i++)
	{
		if(!(reg=(AVCTxt*)AVCBinReadNextTxt(file)))
			error("Error while reading register");

		((int *)idata[0])[i]=reg->nTxtId;
		((int *)idata[1])[i]=reg->nUserId;
		((int *)idata[2])[i]=reg->nLevel;
		((int *)idata[3])[i]=reg->numVerticesLine;
		((int *)idata[4])[i]=reg->numVerticesArrow;

		SET_STRING_ELT(table[5],i, COPY_TO_USER_STRING(reg->pszText));

		SET_VECTOR_ELT(points, i, NEW_LIST(2));
		aux=VECTOR_ELT(points, i);

/*This can be improved storing only the right numnber of vertices*/
		SET_VECTOR_ELT(aux, 0, NEW_NUMERIC(4));
		x=REAL(VECTOR_ELT(aux,0));
		SET_VECTOR_ELT(aux, 1, NEW_NUMERIC(4));
		y=REAL(VECTOR_ELT(aux,1));

		for(j=0;j<4;j++)
		{
			x[j]=reg->pasVertices[j].x;
			y[j]=reg->pasVertices[j].y;
		}

	}

	PROTECT(aux=NEW_LIST(7));

	for(i=0;i<6;i++)
		SET_VECTOR_ELT(aux, i, table[i]);

	SET_VECTOR_ELT(aux, i, points);

	UNPROTECT(8);

	free(table);
	free(idata);

	return aux;
}
示例#5
0
/* par fn gr method options */
SEXP optim(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP par, fn, gr, method, options, tmp, slower, supper;
    SEXP res, value, counts, conv;
    int i, npar=0, *mask, trace, maxit, fncount = 0, grcount = 0, nREPORT, tmax;
    int ifail = 0;
    double *dpar, *opar, val = 0.0, abstol, reltol, temp;
    const char *tn;
    OptStruct OS;
    PROTECT_INDEX par_index;

    args = CDR(args);
    OS = (OptStruct) R_alloc(1, sizeof(opt_struct));
    OS->usebounds = 0;
    OS->R_env = rho;
    par = CAR(args);
    OS->names = getAttrib(par, R_NamesSymbol);
    args = CDR(args); fn = CAR(args);
    if (!isFunction(fn)) error(_("'fn' is not a function"));
    args = CDR(args); gr = CAR(args);
    args = CDR(args); method = CAR(args);
    if (!isString(method)|| LENGTH(method) != 1)
	error(_("invalid '%s' argument"), "method");
    tn = CHAR(STRING_ELT(method, 0));
    args = CDR(args); options = CAR(args);
    PROTECT(OS->R_fcall = lang2(fn, R_NilValue));
    PROTECT_WITH_INDEX(par = coerceVector(par, REALSXP), &par_index);
    if (MAYBE_REFERENCED(par))
    	REPROTECT(par = duplicate(par), par_index);
    npar = LENGTH(par);
    dpar = vect(npar);
    opar = vect(npar);
    trace = asInteger(getListElement(options, "trace"));
    OS->fnscale = asReal(getListElement(options, "fnscale"));
    tmp = getListElement(options, "parscale");
    if (LENGTH(tmp) != npar)
	error(_("'parscale' is of the wrong length"));
    PROTECT(tmp = coerceVector(tmp, REALSXP));
    OS->parscale = vect(npar);
    for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i];
    UNPROTECT(1);
    for (i = 0; i < npar; i++)
	dpar[i] = REAL(par)[i] / (OS->parscale[i]);
    PROTECT(res = allocVector(VECSXP, 5));
    SEXP names;
    PROTECT(names = allocVector(STRSXP, 5));
    SET_STRING_ELT(names, 0, mkChar("par"));
    SET_STRING_ELT(names, 1, mkChar("value"));
    SET_STRING_ELT(names, 2, mkChar("counts"));
    SET_STRING_ELT(names, 3, mkChar("convergence"));
    SET_STRING_ELT(names, 4, mkChar("message"));
    setAttrib(res, R_NamesSymbol, names);
    UNPROTECT(1);
    PROTECT(value = allocVector(REALSXP, 1));
    PROTECT(counts = allocVector(INTSXP, 2));
    SEXP countnames;
    PROTECT(countnames = allocVector(STRSXP, 2));
    SET_STRING_ELT(countnames, 0, mkChar("function"));
    SET_STRING_ELT(countnames, 1, mkChar("gradient"));
    setAttrib(counts, R_NamesSymbol, countnames);
    UNPROTECT(1);
    PROTECT(conv = allocVector(INTSXP, 1));
    abstol = asReal(getListElement(options, "abstol"));
    reltol = asReal(getListElement(options, "reltol"));
    maxit = asInteger(getListElement(options, "maxit"));
    if (maxit == NA_INTEGER) error(_("'maxit' is not an integer"));

    if (strcmp(tn, "Nelder-Mead") == 0) {
	double alpha, beta, gamm;

	alpha = asReal(getListElement(options, "alpha"));
	beta = asReal(getListElement(options, "beta"));
	gamm = asReal(getListElement(options, "gamma"));
	nmmin(npar, dpar, opar, &val, fminfn, &ifail, abstol, reltol,
	      (void *)OS, alpha, beta, gamm, trace, &fncount, maxit);
	for (i = 0; i < npar; i++)
	    REAL(par)[i] = opar[i] * (OS->parscale[i]);
	grcount = NA_INTEGER;

    }
    else if (strcmp(tn, "SANN") == 0) {
	tmax = asInteger(getListElement(options, "tmax"));
	temp = asReal(getListElement(options, "temp"));
	if (trace) trace = asInteger(getListElement(options, "REPORT"));
	if (tmax == NA_INTEGER || tmax < 1) // PR#15194
	    error(_("'tmax' is not a positive integer"));
	if (!isNull(gr)) {
	    if (!isFunction(gr)) error(_("'gr' is not a function"));
		PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
	} else {
	    PROTECT(OS->R_gcall = R_NilValue); /* for balance */
	}
	samin (npar, dpar, &val, fminfn, maxit, tmax, temp, trace, (void *)OS);
	for (i = 0; i < npar; i++)
	    REAL(par)[i] = dpar[i] * (OS->parscale[i]);
	fncount = npar > 0 ? maxit : 1;
	grcount = NA_INTEGER;
	UNPROTECT(1);  /* OS->R_gcall */

    } else if (strcmp(tn, "BFGS") == 0) {
	SEXP ndeps;

	nREPORT = asInteger(getListElement(options, "REPORT"));
	if (!isNull(gr)) {
	    if (!isFunction(gr)) error(_("'gr' is not a function"));
	    PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
	} else {
	    PROTECT(OS->R_gcall = R_NilValue); /* for balance */
	    ndeps = getListElement(options, "ndeps");
	    if (LENGTH(ndeps) != npar)
		error(_("'ndeps' is of the wrong length"));
	    OS->ndeps = vect(npar);
	    PROTECT(ndeps = coerceVector(ndeps, REALSXP));
	    for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
	    UNPROTECT(1);
	}
	mask = (int *) R_alloc(npar, sizeof(int));
	for (i = 0; i < npar; i++) mask[i] = 1;
	vmmin(npar, dpar, &val, fminfn, fmingr, maxit, trace, mask, abstol,
	      reltol, nREPORT, (void *)OS, &fncount, &grcount, &ifail);
	for (i = 0; i < npar; i++)
	    REAL(par)[i] = dpar[i] * (OS->parscale[i]);
	UNPROTECT(1); /* OS->R_gcall */
    } else if (strcmp(tn, "CG") == 0) {
	int type;
	SEXP ndeps;

	type = asInteger(getListElement(options, "type"));
	if (!isNull(gr)) {
	    if (!isFunction(gr)) error(_("'gr' is not a function"));
	    PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
	} else {
	    PROTECT(OS->R_gcall = R_NilValue); /* for balance */
	    ndeps = getListElement(options, "ndeps");
	    if (LENGTH(ndeps) != npar)
		error(_("'ndeps' is of the wrong length"));
	    OS->ndeps = vect(npar);
	    PROTECT(ndeps = coerceVector(ndeps, REALSXP));
	    for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
	    UNPROTECT(1);
	}
	cgmin(npar, dpar, opar, &val, fminfn, fmingr, &ifail, abstol,
	      reltol, (void *)OS, type, trace, &fncount, &grcount, maxit);
	for (i = 0; i < npar; i++)
	    REAL(par)[i] = opar[i] * (OS->parscale[i]);
	UNPROTECT(1); /* OS->R_gcall */

    } else if (strcmp(tn, "L-BFGS-B") == 0) {
	SEXP ndeps, smsg;
	double *lower = vect(npar), *upper = vect(npar);
	int lmm, *nbd = (int *) R_alloc(npar, sizeof(int));
	double factr, pgtol;
	char msg[60];

	nREPORT = asInteger(getListElement(options, "REPORT"));
	factr = asReal(getListElement(options, "factr"));
	pgtol = asReal(getListElement(options, "pgtol"));
	lmm = asInteger(getListElement(options, "lmm"));
	if (!isNull(gr)) {
	    if (!isFunction(gr)) error(_("'gr' is not a function"));
	    PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
	} else {
	    PROTECT(OS->R_gcall = R_NilValue); /* for balance */
	    ndeps = getListElement(options, "ndeps");
	    if (LENGTH(ndeps) != npar)
		error(_("'ndeps' is of the wrong length"));
	    OS->ndeps = vect(npar);
	    PROTECT(ndeps = coerceVector(ndeps, REALSXP));
	    for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
	    UNPROTECT(1);
	}
	args = CDR(args); slower = CAR(args); /* coerce in calling code */
	args = CDR(args); supper = CAR(args);
	for (i = 0; i < npar; i++) {
	    lower[i] = REAL(slower)[i] / (OS->parscale[i]);
	    upper[i] = REAL(supper)[i] / (OS->parscale[i]);
	    if (!R_FINITE(lower[i])) {
		if (!R_FINITE(upper[i])) nbd[i] = 0; else nbd[i] = 3;
	    } else {
		if (!R_FINITE(upper[i])) nbd[i] = 1; else nbd[i] = 2;
	    }
	}
	OS->usebounds = 1;
	OS->lower = lower;
	OS->upper = upper;
	lbfgsb(npar, lmm, dpar, lower, upper, nbd, &val, fminfn, fmingr,
	       &ifail, (void *)OS, factr, pgtol, &fncount, &grcount,
	       maxit, msg, trace, nREPORT);
	for (i = 0; i < npar; i++)
	    REAL(par)[i] = dpar[i] * (OS->parscale[i]);
	UNPROTECT(1); /* OS->R_gcall */
	PROTECT(smsg = mkString(msg));
	SET_VECTOR_ELT(res, 4, smsg);
	UNPROTECT(1);
    } else
	error(_("unknown 'method'"));

    if(!isNull(OS->names)) setAttrib(par, R_NamesSymbol, OS->names);
    REAL(value)[0] = val * (OS->fnscale);
    SET_VECTOR_ELT(res, 0, par); SET_VECTOR_ELT(res, 1, value);
    INTEGER(counts)[0] = fncount; INTEGER(counts)[1] = grcount;
    SET_VECTOR_ELT(res, 2, counts);
    INTEGER(conv)[0] = ifail;
    SET_VECTOR_ELT(res, 3, conv);
    UNPROTECT(6);
    return res;
}
示例#6
0
文件: RArcInfo.c 项目: cran/RArcInfo
/*
It returns the table names and something more:
- Arc file
- Number of fields
- Register Size
- Number of registers
- External/Internal Table Identifier
*/
SEXP get_table_names(SEXP directory)
{
	SEXP *table, aux;
	AVCRawBinFile *arcfile;
	AVCTableDef tabledefaux;
	char arcdir[PATH], *dirname;
	int i,n, **idata;

	dirname= (char *) CHAR(STRING_ELT(directory,0));/*FIXME*/
	strcpy(arcdir,dirname);

	complete_path(arcdir,"arc.dir", 0);

	if(!(arcfile=AVCRawBinOpen(arcdir,"r")))
	{
		error("Error opening arc.dir");
	}

	n=0;
	while(!AVCRawBinEOF(arcfile))
	{
		if(!_AVCBinReadNextArcDir(arcfile, &tabledefaux))
			n++;
	}

	AVCRawBinFSeek(arcfile, 0,SEEK_SET);

	table=calloc(6, sizeof(SEXP));

	PROTECT(table[0]=NEW_STRING(n));
	PROTECT(table[1]=NEW_STRING(n));

	idata=calloc(4, sizeof(char *));
	PROTECT(table[2]=NEW_INTEGER(n));
	idata[0]=INTEGER(table[2]);
	PROTECT(table[3]=NEW_INTEGER(n));
	idata[1]=INTEGER(table[3]);
	PROTECT(table[4]=NEW_INTEGER(n));
	idata[2]=INTEGER(table[4]);
	PROTECT(table[5]=NEW_LOGICAL(n));
	idata[3]=LOGICAL(table[5]);


	i=0;
	while(!AVCRawBinEOF(arcfile))
	{
		if(_AVCBinReadNextArcDir(arcfile, &tabledefaux))
			break;


		SET_STRING_ELT(table[0],i,COPY_TO_USER_STRING(tabledefaux.szTableName));
		SET_STRING_ELT(table[1],i,COPY_TO_USER_STRING(tabledefaux.szInfoFile));

		idata[0][i]=tabledefaux.numFields;
		idata[1][i]=tabledefaux.nRecSize;
		idata[2][i]=tabledefaux.numRecords;
		if(!strcmp(tabledefaux.szExternal,"XX"))
			idata[3][i]=1;
		else
			idata[3][i]=0;

		i++;
	}

	PROTECT(aux=NEW_LIST(6));

	for(i=0;i<6;i++)
		SET_VECTOR_ELT(aux,i,table[i]);

	UNPROTECT(7);

	free(table);
	free(idata);

	return aux;
}
示例#7
0
文件: RArcInfo.c 项目: cran/RArcInfo
SEXP get_lab_data(SEXP directory, SEXP coverage, SEXP filename) 
{
	int i,n;
	void **pdata;
	char pathtofile[PATH];
	AVCLab *reg;
	AVCBinFile *file;
	SEXP *table,aux;


	strcpy(pathtofile, CHAR(STRING_ELT(directory,0)));

	complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)),1);/*FIXME*/

	if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileLAB)))
		error("Error opening file");

	n=0;

	while(AVCBinReadNextLab(file)){n++;}

	Rprintf("Number of LABELS:%d\n",n);


	table=calloc(8, sizeof(SEXP));
	pdata=calloc(8, sizeof(void *));

	PROTECT(table[0]=NEW_INTEGER(n));
	pdata[0]=INTEGER(table[0]);
	PROTECT(table[1]=NEW_INTEGER(n));
	pdata[1]=INTEGER(table[1]);

	for(i=2;i<8;i++)
	{
		PROTECT(table[i]=NEW_NUMERIC(n));
		pdata[i]=REAL(table[i]);

	}

	if(AVCBinReadRewind(file))
		error("Rewind");

	for(i=0;i<n;i++)
	{
		if(!(reg=(AVCLab*)AVCBinReadNextLab(file)))
			error("Error while reading register");


		((int *)pdata[0])[i]=reg->nValue;
		((int *)pdata[1])[i]=reg->nPolyId;

		((double*)pdata[2])[i]=reg->sCoord1.x;
		((double*)pdata[3])[i]=reg->sCoord1.y;
		((double*)pdata[4])[i]=reg->sCoord2.x;
		((double*)pdata[5])[i]=reg->sCoord2.y;
		((double*)pdata[6])[i]=reg->sCoord3.x;
		((double*)pdata[7])[i]=reg->sCoord3.y;
		
	}


	PROTECT(aux=NEW_LIST(8));

	for(i=0;i<8;i++)
	{
		SET_VECTOR_ELT(aux,i,table[i]);
	}

	UNPROTECT(9);

	free(table);
	free(pdata);

	return aux;
}
示例#8
0
文件: subset.old.c 项目: Glanda/xts
SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop)
{
    SEXP attr, result, dim;
    int nr, nc, nrs, ncs;
    int i, j, ii, jj, ij, iijj;
    int mode;
    int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL;
    double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL;

    nr = nrows(x);
    nc = ncols(x);

    if( length(x)==0 )
      return x;

    dim = getAttrib(x, R_DimSymbol);

    nrs = LENGTH(sr);
    ncs = LENGTH(sc);
    int *int_sr=NULL, *int_sc=NULL;
    int_sr = INTEGER(sr);
    int_sc = INTEGER(sc);

    mode = TYPEOF(x);

    result = allocVector(mode, nrs*ncs);
    PROTECT(result);


    if( mode==INTSXP ) {
      int_x = INTEGER(x);
      int_result = INTEGER(result);
    } else
    if( mode==REALSXP ) {
      real_x = REAL(x);
      real_result = REAL(result);
    }

    /* code to handle index of xts object efficiently */
    SEXP index, newindex;
    int indx;

    index = getAttrib(x, install("index"));
    PROTECT(index);

    if(TYPEOF(index) == INTSXP) {
      newindex = allocVector(INTSXP, LENGTH(sr));
      PROTECT(newindex);
      int_newindex = INTEGER(newindex);
      int_index = INTEGER(index);
      for(indx = 0; indx < nrs; indx++) {
        int_newindex[indx] = int_index[ (int_sr[indx])-1];
      }
      copyAttributes(index, newindex);
      setAttrib(result, install("index"), newindex);
      UNPROTECT(1);
    }
    if(TYPEOF(index) == REALSXP) {
      newindex = allocVector(REALSXP, LENGTH(sr));
      PROTECT(newindex);
      real_newindex = REAL(newindex);
      real_index = REAL(index);
      for(indx = 0; indx < nrs; indx++) {
        real_newindex[indx] = real_index[ (int_sr[indx])-1 ];
      }
      copyAttributes(index, newindex);
      setAttrib(result, install("index"), newindex);
      UNPROTECT(1);
    }

    for (i = 0; i < nrs; i++) {
      ii = int_sr[i];
      if (ii != NA_INTEGER) {
        if (ii < 1 || ii > nr)
          error("i is out of range\n");
        ii--;
      }
      /* Begin column loop */
      for (j = 0; j < ncs; j++) {
        //jj = INTEGER(sc)[j];
        jj = int_sc[j];
        if (jj != NA_INTEGER) {
        if (jj < 1 || jj > nc)
          error("j is out of range\n");
        jj--;
        }
        ij = i + j * nrs;
        if (ii == NA_INTEGER || jj == NA_INTEGER) {
          switch ( mode ) {
            case REALSXP:
                 real_result[ij] = NA_REAL;
                 break;
            case LGLSXP:
            case INTSXP:
                 int_result[ij] = NA_INTEGER;
                 break;
            case CPLXSXP:
                 COMPLEX(result)[ij].r = NA_REAL;
                 COMPLEX(result)[ij].i = NA_REAL;
                 break;
            case STRSXP:
                 SET_STRING_ELT(result, ij, NA_STRING);
                 break;
            case VECSXP:
                 SET_VECTOR_ELT(result, ij, R_NilValue);
                 break;
            case RAWSXP:
                 RAW(result)[ij] = (Rbyte) 0;
                 break;
            default:
                 error("xts subscripting not handled for this type");
                 break;
          }
        }
        else {
          iijj = ii + jj * nr;
          switch ( mode ) {
            case REALSXP:
                 real_result[ij] = real_x[iijj];
                 break;
            case LGLSXP:
                 LOGICAL(result)[ij] = LOGICAL(x)[iijj];
                 break;
            case INTSXP:
                 int_result[ij] = int_x[iijj]; 
                 break;
            case CPLXSXP:
                 COMPLEX(result)[ij] = COMPLEX(x)[iijj];
                 break;
            case STRSXP:
                 SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
                 break;
            case VECSXP:
                 SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj));
                 break;
            case RAWSXP:
                 RAW(result)[ij] = RAW(x)[iijj];
                 break;
            default:
                 error("matrix subscripting not handled for this type");
                 break;
          }
        }
      } /* end of column loop */
    } /* end of row loop */
    if(nrs >= 0 && ncs >= 0 && !isNull(dim)) {
      PROTECT(attr = allocVector(INTSXP, 2));
      INTEGER(attr)[0] = nrs;
      INTEGER(attr)[1] = ncs;
      setAttrib(result, R_DimSymbol, attr);
      UNPROTECT(1);
    }

    /* The matrix elements have been transferred.  Now we need to */
    /* transfer the attributes.  Most importantly, we need to subset */
    /* the dimnames of the returned value. */

    if (nrs >= 0 && ncs >= 0 && !isNull(dim)) {
    SEXP dimnames, dimnamesnames, newdimnames;
    dimnames = getAttrib(x, R_DimNamesSymbol);
    dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
    if (!isNull(dimnames)) {
        PROTECT(newdimnames = allocVector(VECSXP, 2));
        if (TYPEOF(dimnames) == VECSXP) {
          SET_VECTOR_ELT(newdimnames, 0,
            xtsExtractSubset(VECTOR_ELT(dimnames, 0),
                  allocVector(STRSXP, nrs), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            xtsExtractSubset(VECTOR_ELT(dimnames, 1),
                  allocVector(STRSXP, ncs), sc));
        }
        else {
          SET_VECTOR_ELT(newdimnames, 0,
            xtsExtractSubset(CAR(dimnames),
                  allocVector(STRSXP, nrs), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            xtsExtractSubset(CADR(dimnames),
                  allocVector(STRSXP, ncs), sc));
        }
        setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
        setAttrib(result, R_DimNamesSymbol, newdimnames);
        UNPROTECT(1);
    }
    }

    copyAttributes(x, result);
    if(ncs == 1 && LOGICAL(drop)[0])
      setAttrib(result, R_DimSymbol, R_NilValue);

    UNPROTECT(2);
    return result;
}
示例#9
0
文件: R++.hpp 项目: ybouret/yocto4
 virtual ~RObject() throw() { if(is_R)  { UNPROTECT(1); } }
示例#10
0
文件: split.c 项目: thsiung/iotools
SEXP mat_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
               SEXP sWhat, SEXP sSkip, SEXP sNlines) {
  unsigned int ncol = 1, nrow, np = 0, i, N, resilient = asInteger(sResilient);
  int use_ncol = asInteger(sNcol);
  int nsep = -1;
  int skip = INTEGER(sSkip)[0];
  int nlines = INTEGER(sNlines)[0];
  int len;
  SEXP res, rnam, zerochar = 0;
  char sep;
  char num_buf[48];
  double * res_ptr;
  const char *c, *sraw, *send, *l, *le;;

  /* parse sep input */
  if (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0)
    nsep = (int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0));
  if (TYPEOF(sSep) != STRSXP || LENGTH(sSep) < 1)
    Rf_error("invalid separator");
  sep = CHAR(STRING_ELT(sSep, 0))[0];

  /* check the input data */
  if (TYPEOF(s) == RAWSXP) {
    nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
    sraw = (const char*) RAW(s);
    send = sraw + XLENGTH(s);
    if (nrow >= skip) {
      nrow = nrow - skip;
      for (i = 0; i < skip; i++) sraw = memchr(sraw,'\n',XLENGTH(s)) + 1;
    } else {
      nrow = 0;
      sraw = send;
    }
  } else if (TYPEOF(s) == STRSXP) {
    nrow = LENGTH(s);
    if (nrow >= skip) {
      nrow -= skip;
    } else {
      skip = nrow;
      nrow = 0;
    }
  } else {
    Rf_error("invalid input to split - must be a raw or character vector");
  }
  if (nlines >= 0 && nrow > nlines) nrow = nlines;

  /* If no rows left, return an empty matrix */
  if (!nrow) {
    if (np) UNPROTECT(np);
    return allocMatrix(TYPEOF(sWhat), 0, 0);
  }

  /* count number of columns */
  if (use_ncol < 1) {
    if (TYPEOF(s) == RAWSXP) {
      ncol = 1;
      c = sraw;
      le = memchr(sraw, '\n', send - sraw);
      while ((c = memchr(c, (unsigned char) sep, le - c))) { ncol++; c++; }
    } else {
      c = CHAR(STRING_ELT(s, 0));
      while ((c = strchr(c, sep))) { ncol++; c++; }
      /* if sep and nsep are the same then the first "column" is the key and not the column */
      if (nsep == (int) (unsigned char) sep) ncol--;
    }
  } else ncol = use_ncol;

  /* allocate space for the result */
  N = ncol * nrow;
  switch(TYPEOF(sWhat)) {
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case RAWSXP:
      res = PROTECT(allocMatrix(TYPEOF(sWhat), nrow, ncol));
      break;

    default:
      Rf_error("Unsupported input to what.");
      break;
  }
  if (nsep >= 0) {
    SEXP dn;
    setAttrib(res, R_DimNamesSymbol, (dn = allocVector(VECSXP, 2)));
    SET_VECTOR_ELT(dn, 0, (rnam = allocVector(STRSXP, nrow)));
  }
  np++;

  /* cycle over the rows and parse the data */
  for (i = 0; i < nrow; i++) {
    int j = i;

    /* find the row of data */
    if (TYPEOF(s) == RAWSXP) {
        l = sraw;
        le = memchr(l, '\n', send - l);
        if (!le) le = send;
        sraw = le + 1;
    } else {
        l = CHAR(STRING_ELT(s, i + skip));
        le = l + strlen(l);
    }

    /* if nsep, load rowname */
    if (nsep >= 0) {
      c = memchr(l, nsep, le - l);
      if (c) {
        SET_STRING_ELT(rnam, i, Rf_mkCharLen(l, c - l));
        l = c + 1;
      } else
        SET_STRING_ELT(rnam, i, R_BlankString);
    }

    /* now split the row into elements */
    while (l < le) {
      if (!(c = memchr(l, sep, le - l)))
        c = le;

      if (j >= N) {
        if (resilient) break;
        Rf_error("line %lu: too many columns (expected %u)", (unsigned long)(i + 1), ncol);
      }

      switch(TYPEOF(sWhat)) {
      case LGLSXP:
        len = (int) (c - l);
        if (len > sizeof(num_buf) - 1)
            len = sizeof(num_buf) - 1;
        memcpy(num_buf, l, len);
        num_buf[len] = 0;
        int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
        LOGICAL(res)[j] = (tr || fa) ? tr : NA_INTEGER;
        break;

      case INTSXP:
        len = (int) (c - l);
        /* watch for overflow and truncate -- should we warn? */
        if (len > sizeof(num_buf) - 1)
            len = sizeof(num_buf) - 1;
        memcpy(num_buf, l, len);
        num_buf[len] = 0;
        INTEGER(res)[j] = Strtoi(num_buf, 10);
        break;

      case REALSXP:
        len = (int) (c - l);
        /* watch for overflow and truncate -- should we warn? */
        if (len > sizeof(num_buf) - 1)
            len = sizeof(num_buf) - 1;
        memcpy(num_buf, l, len);
        num_buf[len] = 0;
        REAL(res)[j] = R_atof(num_buf);
        break;

      case CPLXSXP:
        len = (int) (c - l);
        /* watch for overflow and truncate -- should we warn? */
        if (len > sizeof(num_buf) - 1)
            len = sizeof(num_buf) - 1;
        memcpy(num_buf, l, len);
        num_buf[len] = 0;
        COMPLEX(res)[j] = strtoc(num_buf, TRUE);
        break;

      case STRSXP:
        SET_STRING_ELT(res, j, Rf_mkCharLen(l, c - l));
        break;

      case RAWSXP:
        len = (int) (c - l);
        /* watch for overflow and truncate -- should we warn? */
        if (len > sizeof(num_buf) - 1)
            len = sizeof(num_buf) - 1;
        memcpy(num_buf, l, len);
        num_buf[len] = 0;
        RAW(res)[j] = strtoraw(num_buf);
        break;
      }
      l = c + 1;
      j += nrow;
    }

    /* fill up unused columns with NAs */
    while (j < N) {
      switch (TYPEOF(sWhat)) {
      case LGLSXP:
        LOGICAL(res)[j] = NA_INTEGER;
        break;

      case INTSXP:
        INTEGER(res)[j] = NA_INTEGER;
        break;

      case REALSXP:
        REAL(res)[j] = NA_REAL;
        break;

      case CPLXSXP:
        COMPLEX(res)[j].r = NA_REAL;
        COMPLEX(res)[j].i = NA_REAL;
        break;

      case STRSXP:
        SET_STRING_ELT(res, j, R_NaString);
        break;

      case RAWSXP:
        RAW(res)[j] = (Rbyte) 0;
        break;
      }
      j += nrow;
    }
  }

  UNPROTECT(np);
  return res;
}
示例#11
0
文件: spPPGLM.cpp 项目: cran/spBayes
  SEXP spPPGLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP family_r, SEXP weights_r,
	       SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r, 
	       SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r,
	       SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, SEXP betaStarting_r, SEXP w_strStarting_r,
	       SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP nuTuning_r, SEXP betaTuning_r, SEXP w_strTuning_r,
	       SEXP covModel_r, SEXP nSamples_r, SEXP verbose_r, SEXP nReport_r){
    
    /*****************************************
                Common variables
    *****************************************/
    int i,j,k,l,info,nProtect= 0;
    char const *lower = "L";
    char const *upper = "U";
    char const *ntran = "N";
    char const *ytran = "T";
    char const *rside = "R";
    char const *lside = "L";
    const double one = 1.0;
    const double negOne = -1.0;
    const double zero = 0.0;
    const int incOne = 1;

    /*****************************************
                     Set-up
    *****************************************/
    double *Y = REAL(Y_r);
    double *X = REAL(X_r);
    int p = INTEGER(p_r)[0];
    int pp = p*p;
    int n = INTEGER(n_r)[0];

    std::string family = CHAR(STRING_ELT(family_r,0));

    int *weights = INTEGER(weights_r);

    //covariance model
    std::string covModel = CHAR(STRING_ELT(covModel_r,0));

    int m = INTEGER(m_r)[0];
    double *knotsD = REAL(knotsD_r);
    double *knotsCoordsD = REAL(knotsCoordsD_r);

    //priors and starting
    std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));

    double *betaMu = NULL;
    double *betaSd = NULL;
    
    if(betaPrior == "normal"){
      betaMu = REAL(VECTOR_ELT(betaNorm_r, 0)); 
      betaSd = REAL(VECTOR_ELT(betaNorm_r, 1));
    }
    
    double *sigmaSqIG = REAL(sigmaSqIG_r);
    double *phiUnif = REAL(phiUnif_r);

    double phiStarting = REAL(phiStarting_r)[0];
    double sigmaSqStarting = REAL(sigmaSqStarting_r)[0];
    double *betaStarting = REAL(betaStarting_r);
    double *w_strStarting = REAL(w_strStarting_r);

    double sigmaSqIGa = sigmaSqIG[0]; double sigmaSqIGb = sigmaSqIG[1];
    double phiUnifa = phiUnif[0]; double phiUnifb = phiUnif[1];

    //if matern
    double *nuUnif = NULL;
    double nuStarting = 0;
    double nuUnifa = 0, nuUnifb = 0;
    if(covModel == "matern"){
      nuUnif = REAL(nuUnif_r);
      nuStarting = REAL(nuStarting_r)[0];
      nuUnifa = nuUnif[0]; nuUnifb = nuUnif[1]; 
    }

    //tuning
    double *betaTuning = (double *) R_alloc(p*p, sizeof(double)); 
    F77_NAME(dcopy)(&pp, REAL(betaTuning_r), &incOne, betaTuning, &incOne);
    double phiTuning = sqrt(REAL(phiTuning_r)[0]);
    double sigmaSqTuning = sqrt(REAL(sigmaSqTuning_r)[0]);
    double *w_strTuning = REAL(w_strTuning_r);
   
    double nuTuning = 0;
    if(covModel == "matern")
      nuTuning = sqrt(REAL(nuTuning_r)[0]);

    int nSamples = INTEGER(nSamples_r)[0];
    int verbose = INTEGER(verbose_r)[0];
    int nReport = INTEGER(nReport_r)[0];

    if(verbose){
      Rprintf("----------------------------------------\n");
      Rprintf("\tGeneral model description\n");
      Rprintf("----------------------------------------\n");
      Rprintf("Model fit with %i observations.\n\n", n);
      Rprintf("Number of covariates %i (including intercept if specified).\n\n", p);
      Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
      
      Rprintf("Using non-modified predictive process with %i knots.\n\n", m);
    
      Rprintf("Number of MCMC samples %i.\n\n", nSamples);

      Rprintf("Priors and hyperpriors:\n");

      if(betaPrior == "flat"){
	Rprintf("\tbeta flat.\n");
      }else{
	Rprintf("\tbeta normal:\n");
	Rprintf("\t\tmu:"); printVec(betaMu, p);
	Rprintf("\t\tsd:"); printVec(betaSd, p);Rprintf("\n");
      }
      Rprintf("\n");
  
      Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb);
      Rprintf("\n");
      
      Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb);
      Rprintf("\n");
      
      if(covModel == "matern"){
	Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb);	  
      }

      Rprintf("Metropolis tuning values:\n");
  
      Rprintf("\tbeta tuning:\n");
      printMtrx(betaTuning, p, p);
      Rprintf("\n"); 

      Rprintf("\tsigma.sq tuning: %.5f\n", sigmaSqTuning);
      Rprintf("\n");

      Rprintf("\tphi tuning: %.5f\n", phiTuning);
      Rprintf("\n");

      if(covModel == "matern"){
	Rprintf("\tnu tuning: %.5f\n", nuTuning);
	Rprintf("\n");
      }

      Rprintf("Metropolis starting values:\n");
  
      Rprintf("\tbeta starting:\n");
      Rprintf("\t"); printVec(betaStarting, p);
      Rprintf("\n"); 

      Rprintf("\tsigma.sq starting: %.5f\n", sigmaSqStarting);
      Rprintf("\n");

      Rprintf("\tphi starting: %.5f\n", phiStarting);
      Rprintf("\n");

      if(covModel == "matern"){
	Rprintf("\tnu starting: %.5f\n", nuStarting);
	Rprintf("\n");
      }

    } 

    /*****************************************
         Set-up MCMC sample matrices etc.
    *****************************************/
    int nn = n*n, nm = n*m, mm = m*m;

    //spatial parameters
    int nParams, betaIndx, sigmaSqIndx, phiIndx, nuIndx;

    if(covModel != "matern"){
      nParams = p+2;//sigma^2, phi
      betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1;
    }else{
      nParams = p+3;//sigma^2, phi, nu
      betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; nuIndx = phiIndx+1;
    }

    double *spParams = (double *) R_alloc(nParams, sizeof(double));
    
    //set starting
    F77_NAME(dcopy)(&p, betaStarting, &incOne, &spParams[betaIndx], &incOne);

    spParams[sigmaSqIndx] = log(sigmaSqStarting);

    spParams[phiIndx] = logit(phiStarting, phiUnifa, phiUnifb);

    if(covModel == "matern") 
      spParams[nuIndx] = logit(nuStarting, nuUnifa, nuUnifb);

    double *wCurrent = (double *) R_alloc(n, sizeof(double));
    double *w_strCurrent = (double *) R_alloc(m, sizeof(double));
    F77_NAME(dcopy)(&m, w_strStarting, &incOne, w_strCurrent, &incOne);

    //samples and random effects
    SEXP w_r, w_str_r, samples_r, accept_r;

    PROTECT(w_r = allocMatrix(REALSXP, n, nSamples)); nProtect++; 
    double *w = REAL(w_r); zeros(w, n*nSamples);

    PROTECT(w_str_r = allocMatrix(REALSXP, m, nSamples)); nProtect++; 
    double *w_str = REAL(w_str_r); zeros(w_str, m*nSamples);

    PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++; 
    double *samples = REAL(samples_r);

    PROTECT(accept_r = allocMatrix(REALSXP, 1, 1)); nProtect++;


    /*****************************************
       Set-up MCMC alg. vars. matrices etc.
    *****************************************/
    int s=0, status=0, rtnStatus=0, accept=0, batchAccept = 0;
    double logPostCurrent = 0, logPostCand = 0, detCand = 0;
  
    double *P = (double *) R_alloc(nm, sizeof(double));
    double *K = (double *) R_alloc(mm, sizeof(double));
    double *tmp_n = (double *) R_alloc(n, sizeof(double));
    double *tmp_m = (double *) R_alloc(m, sizeof(double));
    double *tmp_nm = (double *) R_alloc(nm, sizeof(double));
    double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future

    double *candSpParams = (double *) R_alloc(nParams, sizeof(double));
    double *w_strCand = (double *) R_alloc(m, sizeof(double));
    double *wCand = (double *) R_alloc(n, sizeof(double));
    double sigmaSq, phi, nu;
    double *beta = (double *) R_alloc(p, sizeof(double));

    double logMHRatio;

    if(verbose){
      Rprintf("-------------------------------------------------\n");
      Rprintf("\t\tSampling\n");
      Rprintf("-------------------------------------------------\n");
      #ifdef Win32
        R_FlushConsole();
      #endif
    }

    logPostCurrent = R_NegInf;

    GetRNGstate();
    for(s = 0; s < nSamples; s++){
 
      //propose   
      mvrnorm(&candSpParams[betaIndx], &spParams[betaIndx], betaTuning, p, false);
      F77_NAME(dcopy)(&p, &candSpParams[betaIndx], &incOne, beta, &incOne);

      candSpParams[sigmaSqIndx] = rnorm(spParams[sigmaSqIndx], sigmaSqTuning);
      sigmaSq = theta[0] = exp(candSpParams[sigmaSqIndx]);

      candSpParams[phiIndx] = rnorm(spParams[phiIndx], phiTuning);
      phi = theta[1] = logitInv(candSpParams[phiIndx], phiUnifa, phiUnifb);

      if(covModel == "matern"){
	candSpParams[nuIndx] = rnorm(spParams[nuIndx], nuTuning);
	nu = theta[2] = logitInv(candSpParams[nuIndx], nuUnifa, nuUnifb);
      }

      for(i = 0; i < m; i++){
	w_strCand[i] = rnorm(w_strCurrent[i], sqrt(w_strTuning[i]));
      }
      
      //construct covariance matrices 
      spCovLT(knotsD, m, theta, covModel, K);
      spCov(knotsCoordsD, nm, theta, covModel, P);
    
      //invert C and log det cov
      detCand = 0;
      F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky failed in spGLM\n");}
      for(i = 0; i < m; i++) detCand += 2*log(K[i*m+i]);
      F77_NAME(dpotri)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky inverse failed in spGLM\n");}
      
      //make \tild{w}
      F77_NAME(dsymv)(lower, &m, &one, K, &m, w_strCand, &incOne, &zero, tmp_m, &incOne);     
      F77_NAME(dgemv)(ytran, &m, &n, &one, P, &m, tmp_m, &incOne, &zero, wCand, &incOne);
      
      //Likelihood with Jacobian  
      logPostCand = 0.0;

      if(betaPrior == "normal"){
	for(i = 0; i < p; i++){
	  logPostCand += dnorm(beta[i], betaMu[i], betaSd[i], 1);
	}
      }

      logPostCand += -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq); 
       
      logPostCand += log(phi - phiUnifa) + log(phiUnifb - phi); 

      if(covModel == "matern"){
	logPostCand += log(nu - nuUnifa) + log(nuUnifb - nu);   
      }

      F77_NAME(dgemv)(ntran, &n, &p, &one, X, &n, beta, &incOne, &zero, tmp_n, &incOne);
      
      if(family == "binomial"){
	logPostCand += binomial_logpost(n, Y, tmp_n, wCand, weights);
      }else if(family == "poisson"){
	logPostCand += poisson_logpost(n, Y, tmp_n, wCand, weights);
      }else{
	error("c++ error: family misspecification in spGLM\n");
      }

      //(-1/2) * tmp_n` *  C^-1 * tmp_n
      logPostCand += -0.5*detCand-0.5*F77_NAME(ddot)(&m, w_strCand, &incOne, tmp_m, &incOne);

      //
      //MH accept/reject	
      //      
  
      //MH ratio with adjustment
      logMHRatio = logPostCand - logPostCurrent;
      
      if(runif(0.0,1.0) <= exp(logMHRatio)){
	F77_NAME(dcopy)(&nParams, candSpParams, &incOne, spParams, &incOne);
	F77_NAME(dcopy)(&n, wCand, &incOne, wCurrent, &incOne);
	F77_NAME(dcopy)(&m, w_strCand, &incOne, w_strCurrent, &incOne);
	logPostCurrent = logPostCand;
	accept++;
	batchAccept++;
      }
      
      /******************************
          Save samples and report
      *******************************/
      F77_NAME(dcopy)(&nParams, spParams, &incOne, &samples[s*nParams], &incOne);
      F77_NAME(dcopy)(&n, wCurrent, &incOne, &w[s*n], &incOne);
      F77_NAME(dcopy)(&m, w_strCurrent, &incOne, &w_str[s*m], &incOne);
      
      //report
      if(verbose){
	if(status == nReport){
	  Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
	  Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
	  Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept/s);
	  Rprintf("-------------------------------------------------\n");
          #ifdef Win32
	  R_FlushConsole();
          #endif
	  status = 0;
	  batchAccept = 0;
	}
      }
      status++;
   
      R_CheckUserInterrupt();
    }//end sample loop
    PutRNGstate();
    
    //final status report
    if(verbose){
      Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
      Rprintf("-------------------------------------------------\n");
      #ifdef Win32
      R_FlushConsole();
      #endif
    }

    //untransform variance variables
    for(s = 0; s < nSamples; s++){
      samples[s*nParams+sigmaSqIndx] = exp(samples[s*nParams+sigmaSqIndx]);

      samples[s*nParams+phiIndx] = logitInv(samples[s*nParams+phiIndx], phiUnifa, phiUnifb);

      if(covModel == "matern")
	samples[s*nParams+nuIndx] = logitInv(samples[s*nParams+nuIndx], nuUnifa, nuUnifb);
    }
   
    //calculate acceptance rate
    REAL(accept_r)[0] = 100.0*accept/s;

    //make return object
    SEXP result, resultNames;
    
    int nResultListObjs = 4;

    PROTECT(result = allocVector(VECSXP, nResultListObjs)); nProtect++;
    PROTECT(resultNames = allocVector(VECSXP, nResultListObjs)); nProtect++;

   //samples
    SET_VECTOR_ELT(result, 0, samples_r);
    SET_VECTOR_ELT(resultNames, 0, mkChar("p.beta.theta.samples")); 

    SET_VECTOR_ELT(result, 1, accept_r);
    SET_VECTOR_ELT(resultNames, 1, mkChar("acceptance"));
    
    SET_VECTOR_ELT(result, 2, w_r);
    SET_VECTOR_ELT(resultNames, 2, mkChar("p.w.samples"));

    SET_VECTOR_ELT(result, 3, w_str_r);
    SET_VECTOR_ELT(resultNames, 3, mkChar("p.w.knots.samples"));
  
    namesgets(result, resultNames);
   
    //unprotect
    UNPROTECT(nProtect);
    
    return(result);
    
  }
示例#12
0
SEXP R_num_to_char(SEXP x, SEXP digits, SEXP na_as_string, SEXP use_signif) {
  int len = length(x);
  int na_string = asLogical(na_as_string);
  int signif = asLogical(use_signif);
  char buf[32];
  SEXP out = PROTECT(allocVector(STRSXP, len));
  if(isInteger(x)){
    for (int i=0; i<len; i++) {
      if(INTEGER(x)[i] == NA_INTEGER){
        if(na_string == NA_LOGICAL){
          SET_STRING_ELT(out, i, NA_STRING);
        } else if(na_string){
          SET_STRING_ELT(out, i, mkChar("\"NA\""));
        } else {
          SET_STRING_ELT(out, i, mkChar("null"));
        }
      } else {
        modp_itoa10(INTEGER(x)[i], buf);
        SET_STRING_ELT(out, i, mkChar(buf));
      }
    }
  } else if(isReal(x)) {
    int precision = asInteger(digits);
    double * xreal = REAL(x);
    for (int i=0; i<len; i++) {
      double val = xreal[i];
      if(!R_FINITE(val)){
        if(na_string == NA_LOGICAL){
          SET_STRING_ELT(out, i, NA_STRING);
        } else if(na_string){
          if(ISNA(val)){
            SET_STRING_ELT(out, i, mkChar("\"NA\""));
          } else if(ISNAN(val)){
            SET_STRING_ELT(out, i, mkChar("\"NaN\""));
          } else if(val == R_PosInf){
            SET_STRING_ELT(out, i, mkChar("\"Inf\""));
          } else if(val == R_NegInf){
            SET_STRING_ELT(out, i, mkChar("\"-Inf\""));
          } else {
            error("Unrecognized non finite value.");
          }
        } else {
          SET_STRING_ELT(out, i, mkChar("null"));
        }
      } else if(precision == NA_INTEGER){
        snprintf(buf, 32, "%.15g", val);
        SET_STRING_ELT(out, i, mkChar(buf));
      } else if(signif){
        //use signifant digits rather than decimal digits
        snprintf(buf, 32, "%.*g", (int) ceil(fmin(15, precision)), val);
        SET_STRING_ELT(out, i, mkChar(buf));
      } else if(precision > -1 && precision < 10 && fabs(val) < 2147483647 && fabs(val) > 1e-5) {
        //preferred method: fast with fixed decimal digits
        //does not support large numbers or scientific notation
        modp_dtoa2(val, buf, precision);
        SET_STRING_ELT(out, i, mkChar(buf));
        //Rprintf("Using modp_dtoa2\n");
      } else {
        //fall back on sprintf (includes scientific notation)
        //limit total precision to 15 significant digits to avoid noise
        //funky formula is mostly to convert decimal digits into significant digits
        snprintf(buf, 32, "%.*g", (int) ceil(fmin(15, fmax(1, log10(val)) + precision)), val);
        SET_STRING_ELT(out, i, mkChar(buf));
        //Rprintf("Using sprintf with precision %d digits\n",(int) ceil(fmin(15, fmax(1, log10(val)) + precision)));
      }
    }
  } else {
    error("num_to_char called with invalid object type.");
  }

  UNPROTECT(1);
  return out;
}
示例#13
0
文件: objects.c 项目: cran/SMC
/*
 * The following returns a R list with the following components:
 * currentStreams
 * currentLogWeights
 * propUniqueStreamIds
 */
static SEXP
resamp_func_builtin_PPW (Sampler *ss, int currentPeriod, SEXP currentStreams,
                         SEXP currentLogWeights)
{
        ResampleContext *rc = ss->scratch_RC;
        int nspr = ss->nStreamsPreResamp, dpp = ss->dimPerPeriod;
        int ns = ss->nStreams, *sids = rc->streamIds, ii, jj, kk;
        int nusids, *usids = rc->uniqueStreamIds;
        int nComps = 0, nProtected = 0;
        double *ps = rc->partialSum;
        double sum, uu;
        SEXP resampCurrentStreams, resampCurrentLogWeights, resampPropUniqueStreamIds;
        SEXP retList, names;
        double *rcs, *rclw;
        double *scs  = REAL(currentStreams);
        double *sclw = REAL(currentLogWeights);
        double *scaw = REAL(ss->SEXPCurrentAdjWeights);
        void *vmax = vmaxget( );

        PROTECT(resampCurrentStreams    = allocMatrix(REALSXP, ns, dpp));
        ++nComps; ++nProtected;
        PROTECT(resampCurrentLogWeights = allocVector(REALSXP, ns));
        ++nComps; ++nProtected;
        rcs  = REAL(resampCurrentStreams);
        rclw = REAL(resampCurrentLogWeights);

        sampler_adjust_log_weights(nspr, sclw, scaw);
        ps[0] = scaw[0];
        for (jj = 1; jj < nspr; ++jj) {
                ps[jj] = ps[jj - 1] + scaw[jj];
        }
        sum = ps[nspr - 1]; nusids = 0;
        /* resample the streams with probability proportional to their
         * weights */
        for (jj = 0; jj < ns; ++jj) {
                uu = runif(0, sum);
                for (ii = 0; ii < nspr; ++ii) {
                        if (uu <= ps[ii]) { sids[jj] = ii; break; }
                }
                /* copying the resampled stream */
                for (kk = 0; kk < dpp; ++kk)
                        rcs[kk * ns + jj] = scs[kk * nspr + sids[jj]];
                /* making the resampled logWeights = 0 */
                rclw[jj] = 0;
                /* find the unique stream and register it */
                if (utils_is_int_in_iarray(sids[jj], nusids, usids) == FALSE) {
                        usids[nusids] = sids[jj]; ++nusids;
                }
        }
        rc->nUniqueStreamIds    = nusids;
        rc->propUniqueStreamIds = nusids / ((double) nspr);
        PROTECT(resampPropUniqueStreamIds = allocVector(REALSXP, 1));
        ++nComps; ++nProtected;
        REAL(resampPropUniqueStreamIds)[0] = rc->propUniqueStreamIds;

        PROTECT(retList = allocVector(VECSXP, nComps)); ++nProtected;
        PROTECT(names   = allocVector(STRSXP, nComps)); ++nProtected;
        nComps = 0;
        SET_VECTOR_ELT(retList, nComps, resampCurrentStreams);
        SET_STRING_ELT(names,   nComps, mkChar("currentStreams"));
        ++nComps;
        SET_VECTOR_ELT(retList, nComps, resampCurrentLogWeights);
        SET_STRING_ELT(names,   nComps, mkChar("currentLogWeights"));
        ++nComps;
        SET_VECTOR_ELT(retList, nComps, resampPropUniqueStreamIds);
        SET_STRING_ELT(names,   nComps, mkChar("propUniqueStreamIds"));
        setAttrib(retList, R_NamesSymbol, names);
        UNPROTECT(nProtected);
        vmaxset(vmax);
        return retList;        
}
示例#14
0
SEXP superSubset(SEXP x, SEXP y, SEXP fuz, SEXP vo, SEXP nec) { 
    int i, j, k, index;
    double *p_x, *p_incovpri, *p_vo, min, max, so = 0.0, sumx_min, sumx_max, sumpmin_min, sumpmin_max, prisum_min, prisum_max, temp1, temp2;
    int xrows, xcols, yrows, *p_y, *p_fuz, *p_nec;
    
    SEXP usage = PROTECT(allocVector(VECSXP, 5));
    SET_VECTOR_ELT(usage, 0, x = coerceVector(x, REALSXP));
    SET_VECTOR_ELT(usage, 1, y = coerceVector(y, INTSXP));
    SET_VECTOR_ELT(usage, 2, fuz = coerceVector(fuz, INTSXP));
    SET_VECTOR_ELT(usage, 3, vo = coerceVector(vo, REALSXP));
    SET_VECTOR_ELT(usage, 4, nec = coerceVector(nec, INTSXP));
    
    xrows = nrows(x);
    yrows = nrows(y);
    xcols = ncols(x);
    
    double copyline[xcols];
    
    p_x = REAL(x);
    p_y = INTEGER(y);
    p_fuz = INTEGER(fuz);
    p_vo = REAL(vo);
    p_nec = INTEGER(nec);
    
    
    // create the list to be returned to R
    SEXP incovpri = PROTECT(allocMatrix(REALSXP, 6, yrows));
    p_incovpri = REAL(incovpri);
    
    
    // sum of the outcome variable
    for (i = 0; i < length(vo); i++) {
        so += p_vo[i];
    }
    
    
    min = 1000;
    max = 0;
    
    for (k = 0; k < yrows; k++) { // loop for every line of the truth table matrix
        
        sumx_min = 0;
        sumx_max = 0;
        sumpmin_min = 0;
        sumpmin_max = 0;
        prisum_min = 0;  
        prisum_max = 0;
        
        for (i = 0; i < xrows; i++) { // loop over every line of the data matrix
            
            for (j = 0; j < xcols; j++) { // loop over each column of the data matrix
                copyline[j] = p_x[i + xrows * j];
                
                index = k + yrows * j;
                
                if (p_fuz[j] == 1) { // for the fuzzy variables, invert those who have the 3k value equal to 1 ("onex3k" in R)
                    if (p_y[index] == 1) {
                        copyline[j] = 1 - copyline[j];
                    }
                }
                else {
                    if (p_y[index] != (copyline[j] + 1)) {
                        copyline[j] = 0;
                    }
                    else {
                        copyline[j] = 1;
                    }
                }
                
                if (p_y[index] != 0) {
                    
                    if (copyline[j] < min) {
                        min = copyline[j];
                    }
                    
                    if (copyline[j] > max) {
                        max = copyline[j];
                    }
                }
                
            } // end of j loop, over columns
            
            sumx_min += min;
            sumx_max += max;
            sumpmin_min += (min < p_vo[i])?min:p_vo[i];
            sumpmin_max += (max < p_vo[i])?max:p_vo[i];
            temp1 = (min < p_vo[i])?min:p_vo[i];
            temp2 = p_nec[0]?(1 - min):(1 - p_vo[i]);
            prisum_min += (temp1 < temp2)?temp1:temp2;
            temp1 = (max < p_vo[i])?max:p_vo[i];
            temp2 = 1 - max;
            prisum_max += (temp1 < temp2)?temp1:temp2;
            
            min = 1000; // re-initialize min and max values
            max = 0;
            
        } // end of i loop
        
        p_incovpri[k*6] = (sumpmin_min == 0 && sumx_min == 0)?0:(sumpmin_min/sumx_min);
        p_incovpri[k*6 + 1] = (sumpmin_min == 0 && so == 0)?0:(sumpmin_min/so);
        p_incovpri[k*6 + 2] = (sumpmin_max == 0 && sumx_max == 0)?0:(sumpmin_max/sumx_max);
        p_incovpri[k*6 + 3] = (sumpmin_max == 0 && so == 0)?0:(sumpmin_max/so);
        
        temp1 = sumpmin_min - prisum_min;
        temp2 = p_nec[0]?so:sumx_min - prisum_min;
        p_incovpri[k*6 + 4] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2);
        
        temp1 = sumpmin_max - prisum_max;
        temp2 = so - prisum_max;
        p_incovpri[k*6 + 5] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2);
        
    } // end of k loop
    
    
    UNPROTECT(2);
    
    return(incovpri);
}
示例#15
0
/* check neighbourhood sets and markov blanets for consistency.. */
SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP filter, SEXP debug) {

int i = 0, j = 0, k = 0, n = 0, counter = 0;
short int *checklist = NULL, err = 0;
int *debuglevel = NULL, *checkmb = NULL, *flt = INTEGER(filter);
SEXP temp, temp2, nodes, elnames = NULL, fixed;

  /* get the names of the nodes. */
  nodes = getAttrib(bn, R_NamesSymbol);
  n = LENGTH(nodes);

  /* allocate and initialize the checklist. */
  checklist = allocstatus(UPTRI_MATRIX(n));

  /* dereference the debug and mb parameters. */
  debuglevel = LOGICAL(debug);
  checkmb = LOGICAL(mb);

  if (*debuglevel > 0) {

    Rprintf("----------------------------------------------------------------\n");

    if (*checkmb)
      Rprintf("* checking consistency of markov blankets.\n");
    else
      Rprintf("* checking consistency of neighbourhood sets.\n");

   }/*THEN*/

  /* scan the structure to determine the number of arcs.  */
  for (i = 0; i < n; i++) {

     if (*debuglevel > 0)
       Rprintf("  > checking node %s.\n",  NODE(i));

    /* get the entry for the (neighbours|elements of the markov blanket)
       of the node.*/
    temp = getListElement(bn, (char *)NODE(i));
    if (!(*checkmb))
      temp = getListElement(temp, "nbr");

    /* check each element of the array and identify which variable it
       corresponds to. */
    for (j = 0; j < LENGTH(temp); j++) {

      for (k = 0; k < n; k++) {

        /* increment the right element of checklist. */
        if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j))))
          checklist[UPTRI(i + 1, k + 1, n)]++;

      }/*FOR*/

    }/*FOR*/

  }/*FOR*/

  /* if A is a neighbour of B, B is a neighbour of A; therefore each entry in
   * the checklist array must be equal to either zero (if the corresponding
   * nodes are not neighbours) or two (if the corresponding nodes are neighbours).
   * Any other value (typically one) is caused by an incorrect (i.e. asymmetric)
   * neighbourhood structure. The same logic holds for the markov blankets. */
  for (i = 0; i < n; i++)
    for (j = i; j < n; j++) {

      if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) &&
          (checklist[UPTRI(i + 1, j + 1, n)] != 2)) {

        if (*debuglevel > 0) {

          if (*checkmb)
            Rprintf("@ asymmetry in the markov blankets for %s and %s.\n",
              NODE(i), NODE(j));
          else
            Rprintf("@ asymmetry in the neighbourhood sets for %s and %s.\n",
              NODE(i), NODE(j));

        }/*THEN*/

        err = 1;

      }/*THEN*/

    }/*FOR*/

  /* no need to go on if the (neighbourhood sets|markov blankets) are symmetric;
   * otherwise throw either an error or a warning according to the value of the
   * strict parameter. */
  if (!err) {

    return bn;

  }/*THEN*/
  else if (isTRUE(strict)) {

    if (*checkmb)
      error("markov blankets are not symmetric.\n");
    else
      error("neighbourhood sets are not symmetric.\n");

  }/*THEN*/

  /* build a correct structure to return. */
  PROTECT(fixed = allocVector(VECSXP, n));
  setAttrib(fixed, R_NamesSymbol, nodes);

  if (!(*checkmb)) {

    /* allocate colnames. */
    PROTECT(elnames = allocVector(STRSXP, 2));
    SET_STRING_ELT(elnames, 0, mkChar("mb"));
    SET_STRING_ELT(elnames, 1, mkChar("nbr"));

  }/*THEN*/

  for (i = 0; i < n; i++) {

    if (!(*checkmb)) {

      /* allocate the "mb" and "nbr" elements of the node. */
      PROTECT(temp = allocVector(VECSXP, 2));
      SET_VECTOR_ELT(fixed, i, temp);
      setAttrib(temp, R_NamesSymbol, elnames);

      /* copy the "mb" part from the old structure. */
      temp2 = getListElement(bn, (char *)NODE(i));
      temp2 = getListElement(temp2, "mb");
      SET_VECTOR_ELT(temp, 0, temp2);

    }/*THEN*/

    /* rescan the checklist. */
    for (j = 0; j < n; j++)
      if (checklist[UPTRI(i + 1, j + 1, n)] >= *flt)
        if (i != j)
          counter++;

    /* allocate and fill the "nbr" element. */
    PROTECT(temp2 = allocVector(STRSXP, counter));

    for (j = 0; j < n; j++)
      if (checklist[UPTRI(i + 1, j + 1, n)] >= *flt)
        if (i != j)
          SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));

    if (*checkmb) {

      SET_VECTOR_ELT(fixed, i, temp2);
      UNPROTECT(1);

    }/*THEN*/
    else {

      SET_VECTOR_ELT(temp, 1, temp2);
      UNPROTECT(2);

    }/*ELSE*/

  }/*FOR*/

  if (*checkmb)
    UNPROTECT(1);
  else
    UNPROTECT(2);

return fixed;

}/*BN_RECOVERY*/
示例#16
0
// m and n should be the same. This code should be updated at some point.
SEXP pair_wmw_test(SEXP _X, SEXP _Y, SEXP _corr, SEXP _method, SEXP _mc_rep, SEXP _comb){
    
    int m=length(_X);
    int n=length(_Y);
    int N=m+n;
    int i,b;
    int corr=asInteger(_corr);// 0,1,-1,2
    int method=asInteger(_method);// 0,1,2,3,4
    double *X0=REAL(_X), *Y0=REAL(_Y);  
    int *comb=INTEGER(_comb);
    double ind;
      
    double *X = malloc(m*sizeof(double));
    double *Y = malloc(n*sizeof(double));
    double *xy = malloc(N*sizeof(double));
    double *unique = malloc(N*sizeof(double));
    int *nties = malloc(N*sizeof(int));
        
    int mc_rep=asInteger(_mc_rep); // 0: exact perm, 1: z only, 1e4: mc
    int nperm=length(_comb)/m; // number of permutation
    SEXP _ans=PROTECT(allocVector(REALSXP, mc_rep==0?nperm:mc_rep));
    double *ans=REAL(_ans);
    
//    // NTIES <- table(r)
//    for (i = 0; i < N; i++) nties[i]=1;
//    int n_unique=0;
//    int flag;
//    for (i = 0; i < N; i++) {
//        flag=0;
//        for (j= 0; j < n_unique; j++) {
//            if (xy0[i]==unique[j]) {
//            //PRINTF("inside\n");
//                nties[j]++;
//                flag=1;
//                break;
//            }
//        }    
//        if(flag==0) unique[n_unique++]=xy0[i];
//    }
//    //for (i = 0; i < n_unique; i++) PRINTF("%f ", unique[i]); PRINTF("\n");
//    //for (i = 0; i < n_unique; i++) PRINTF("%i ", nties[i]); PRINTF("\n");
//    // sum(NTIES^3-NTIES)/(12*m*n*N*(N - 1))
    double adj=0;
//    for (i = 0; i < n_unique; i++) {
//        if(nties[i]>1) adj+= (pow(nties[i],3)-nties[i]);
//    }
//    adj/=(12.*m*n*N*(N-1));


    if(mc_rep==1) {
        ans[0]=compute_pair_wmw_Z(X0, Y0, xy, m, n, corr, method, adj, 0); 
    } else {
        if (mc_rep>1) {
            // Monte Carlo
            for (b=0; b<mc_rep; b++) {                
                for (i = 0; i < m; i++) {
                    ind=RUNIF(0.0,1.0);
                    X[i]=ind< 0.5?X0[i]:Y0[i];
                    Y[i]=ind>=0.5?X0[i]:Y0[i];
                }
                ans[b]=compute_pair_wmw_Z(X, Y, xy, m, n, corr, method, adj, 0);        
            }    
        } else {
            // exact   
         	int c=0;
            for (b=0; b<nperm; b++) {
                //PRINTF("%i ", b); 
                for (i = 0; i < m; i++) {
                    ind=comb[c++];   
                    X[i]=ind==0?X0[i]:Y0[i];
                    Y[i]=ind==1?X0[i]:Y0[i];
                }
                ans[b]=compute_pair_wmw_Z(X, Y, xy, m, n, corr, method, adj, 0);        
            }    
        }
        //for (b=0; b<mc_rep; b++) PRINTF("%f ", ans[b]); PRINTF("\n");
    }
            
    free(X); free(Y); free(xy); 
    free(unique); free(nties);

    UNPROTECT(1);
    return _ans;
}
示例#17
0
文件: RArcInfo.c 项目: cran/RArcInfo
/*It imports the data from an arc file*/
SEXP get_arc_data(SEXP directory, SEXP coverage, SEXP filename) 
{
	int i,j,n, **ptable;
	double *x,*y;
	char pathtofile[PATH];
	AVCArc *reg;
	AVCBinFile *file;
	SEXP *table, points, aux;


	strcpy(pathtofile, CHAR(STRING_ELT(directory,0)));

	complete_path(pathtofile, (char *)CHAR(STRING_ELT(coverage,0)), 1);

	if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileARC)))
		error("Error opening file");

	n=0;

	while(AVCBinReadNextArc(file)){n++;}

	Rprintf("Number of ARCS:%d\n",n);


	table=calloc(7,sizeof(SEXP));
	ptable=(int **)calloc(7, sizeof(int *));
	for(i=0;i<7;i++)
	{
		PROTECT(table[i]=NEW_INTEGER(n));
		ptable[i]=(int *)INTEGER(table[i]);
	}


	PROTECT(points=NEW_LIST(n));

	if(AVCBinReadRewind(file))
		error("Rewind");

	for(i=0;i<n;i++)
	{
		
		if(!(reg=(AVCArc*)AVCBinReadNextArc(file)))
			error("Error while reading register");


		ptable[0][i]=reg->nArcId;

		ptable[1][i]=reg->nUserId;

		ptable[2][i]=reg->nFNode;

		ptable[3][i]=reg->nTNode;

		ptable[4][i]=reg->nLPoly;

		ptable[5][i]=reg->nRPoly;

		ptable[6][i]=reg->numVertices;

		SET_VECTOR_ELT(points,i,NEW_LIST(2));

		aux=VECTOR_ELT(points,i);

		SET_VECTOR_ELT(aux,0,NEW_NUMERIC(reg->numVertices));
		SET_VECTOR_ELT(aux,1,NEW_NUMERIC(reg->numVertices));

		x=REAL(VECTOR_ELT(aux,0));
		y=REAL(VECTOR_ELT(aux,1));

		for(j=0;j<reg->numVertices;j++)
		{
			x[j]=reg->pasVertices[j].x;
			y[j]=reg->pasVertices[j].y;
		}

	}

	PROTECT(aux=NEW_LIST(8));

	for(i=0;i<7;i++)
	{
		SET_VECTOR_ELT(aux,i,table[i]);
	}

	SET_VECTOR_ELT(aux,7,points);

	UNPROTECT(9);

	free(table);
	return aux;
}
示例#18
0
/**
 *     Logistic regression stochastic average gradient trainer
 *
 *     @param w(p, 1) weights
 *     @param Xt(p, n) real feature matrix
 *     @param y(n, 1) {-1, 1} target matrix
 *     @param lambda scalar regularization parameters
 *     @param Li scalar constant step size
 *     @param iVals(max_iter, 1) sequence of examples to choose
 *     @param d(p, 1) initial approximation of average gradient
 *     @param g(n, 1) previous derivatives of loss
 *     @param covered(n, 1) whether the example has been visited
 *     @param stepSizeType scalar default is 1 to use 1/L, set to 2 to
 *     use 2/(L + n*myu)
 *     @return optimal weights (p, 1)
 */
SEXP C_sag(SEXP wInit, SEXP Xt, SEXP y, SEXP lambdas,
           SEXP alpha,  // SAG Constant Step size
           SEXP stepSizeType, // SAG Linesearch
           SEXP LiInit,  // SAG Linesearch and Adaptive
           SEXP LmaxInit,  // SAG Adaptive
           SEXP increasing,  // SAG Adaptive
           SEXP dInit, SEXP gInit, SEXP coveredInit,
           SEXP tol, SEXP maxiter,
           SEXP family,
           SEXP fit_alg,
           SEXP ex_model_params,
           SEXP sparse) {
 /*===============\
 | Error Checking |
 \===============*/
  validate_inputs(wInit, Xt, y, dInit, gInit, coveredInit, sparse);
  /* Initializing protection counter */
  int nprot = 0;
  /* Duplicating objects to be modified */
  SEXP w = PROTECT(duplicate(wInit)); nprot++;
  SEXP d = PROTECT(duplicate(dInit)); nprot++;
  SEXP g = PROTECT(duplicate(gInit)); nprot++;
  SEXP covered = PROTECT(duplicate(coveredInit)); nprot++;
  SEXP Li = PROTECT(duplicate(LiInit)); nprot++;
  SEXP Lmax = PROTECT(duplicate(LmaxInit)); nprot++;
  /*======\
  | Input |
  \======*/
  /* Initializing dataset */
  Dataset train_set = make_Dataset(Xt, y, covered, Lmax, Li, increasing, fit_alg, sparse);
  /* Initializing Trainer */
  GlmTrainer trainer = make_GlmTrainer(R_NilValue, alpha, d, g, maxiter,
                                       stepSizeType, tol, fit_alg,
                                       R_NilValue, R_NilValue);
  /* Initializing Model */
  GlmModel model = make_GlmModel(w, family, ex_model_params);
  /*============================\
  | Stochastic Average Gradient |
  \============================*/
  /* Initializing lambda/weights Matrix*/
  SEXP lambda_w = PROTECT(allocMatrix(REALSXP, train_set.nVars, LENGTH(lambdas))); nprot++;
  Memzero(REAL(lambda_w), LENGTH(lambdas) * train_set.nVars);
  /* Training */
  sag_warm(&trainer, &model, &train_set,
           REAL(lambdas), LENGTH(lambdas), REAL(lambda_w));
  /* Cleanup */
  cleanup(&trainer, &model, &train_set);
  /*=======\
  | Return |
  \=======*/
  SEXP convergence_code = PROTECT(allocVector(INTSXP, 1)); nprot++;
  *INTEGER(convergence_code) = trainer.convergence_code;
  SEXP iter_count = PROTECT(allocVector(INTSXP, 1)); nprot++;
  *INTEGER(iter_count) = trainer.iter_count;
  /* Assigning variables to SEXP list */
  SEXP results = PROTECT(allocVector(VECSXP, 8)); nprot++;
  INC_APPLY(SEXP, SET_VECTOR_ELT, results, lambda_w, d, g, covered,
            Li, Lmax, convergence_code, iter_count); // in utils.h
  /* Creating SEXP for list names */
  SEXP results_names = PROTECT(allocVector(STRSXP, 8)); nprot++;
  INC_APPLY_SUB(char *, SET_STRING_ELT, mkChar, results_names, "lambda_w", "d", "g",
                "covered", "Li", "Lmax", "convergence_code", "iter_count");
  setAttrib(results, R_NamesSymbol, results_names);
  /* ------------------------------------------------------------------------ */
  UNPROTECT(nprot);
  return results;
}
示例#19
0
文件: RArcInfo.c 项目: cran/RArcInfo
SEXP get_pal_data(SEXP directory, SEXP coverage, SEXP filename) 
{
	int i,j,n;
	int **idata;
	char pathtofile[PATH];
	void **ptable;
	AVCPal *reg;
	AVCBinFile *file;
	SEXP *table, points, aux;


	strcpy(pathtofile, CHAR(STRING_ELT(directory,0)));


	complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)), 1);


	if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFilePAL)))
		error("Error opening file");

	n=0;

	while(AVCBinReadNextPal(file)){n++;}

	Rprintf("Number of POLYGONS:%d\n",n);

	idata=calloc(3,sizeof(int *));

        table=calloc(6,sizeof(SEXP));
        ptable=(void **)calloc(6, sizeof(void *));

        PROTECT(table[0]=NEW_INTEGER(n));  /*Polygon ID*/
        ptable[0]=(int *)INTEGER(table[0]);
        PROTECT(table[1]=NEW_NUMERIC(n));  /*Min X. coordinate*/
        ptable[1]=(double *)REAL(table[1]);
        PROTECT(table[2]=NEW_NUMERIC(n));  /*Min Y. coordinate*/
        ptable[2]=(double *)REAL(table[2]);
        PROTECT(table[3]=NEW_NUMERIC(n));  /*Max X. coordinate*/
        ptable[3]=(double *)REAL(table[3]);
        PROTECT(table[4]=NEW_NUMERIC(n));  /*Max Y. coordinate*/
        ptable[4]=(double *)REAL(table[4]);
        PROTECT(table[5]=NEW_INTEGER(n));  /*Number of arcs*/
        ptable[5]=(int *)INTEGER(table[5]);
 
 
        PROTECT(points=NEW_LIST(n));  


	if(AVCBinReadRewind(file))
		error("Rewind");

	for(i=0;i<n;i++)
	{
		
		if(!(reg=(AVCPal*)AVCBinReadNextPal(file)))
			error("Error while reading register");


		((int *)ptable[0])[i]=reg->nPolyId;

		((double *)ptable[1])[i]=reg->sMin.x;
		((double *)ptable[2])[i]=reg->sMin.y;

		((double *)ptable[3])[i]=reg->sMax.x;
		((double *)ptable[4])[i]=reg->sMax.y;

		((int *)ptable[5])[i]=reg->numArcs;


		SET_VECTOR_ELT(points,i,NEW_LIST(3));
		aux=VECTOR_ELT(points,i);

		SET_VECTOR_ELT(aux,0,NEW_INTEGER(reg->numArcs));
		idata[0]=INTEGER(VECTOR_ELT(aux,0));
		SET_VECTOR_ELT(aux,1,NEW_INTEGER(reg->numArcs));
		idata[1]=INTEGER(VECTOR_ELT(aux,1));
		SET_VECTOR_ELT(aux,2,NEW_INTEGER(reg->numArcs));
		idata[2]=INTEGER(VECTOR_ELT(aux,2));

		for(j=0;j<reg->numArcs;j++)
		{
			idata[0][j]=reg->pasArcs[j].nArcId;
			idata[1][j]=reg->pasArcs[j].nFNode;
			idata[2][j]=reg->pasArcs[j].nAdjPoly;
		}

	}


        PROTECT(aux=NEW_LIST(7));
 
        for(i=0;i<6;i++)
        {
                SET_VECTOR_ELT(aux,i,table[i]);
        }
 
        SET_VECTOR_ELT(aux,6,points);
 
        UNPROTECT(8);  


	free(ptable);
	free(idata);

	return aux;
}
示例#20
0
SEXP calc_het(SEXP C, SEXP LG, SEXP n, SEXP ncol, SEXP nrow)
/*********************************************************************** 
 * Functie om de heterogeniteit van een 3x3 focal area (neighbourhood)
 * in de LG kaart te berekenen.
 *
 * INVOER:
 *
 * C    = celnummers van geselecteerde rastercellen
 * LG   = LG kaart (geselecteerde cellen) als vector (de LG kaart mag 
 *        alleen de codes 1 t/m 5 of een NA bevatten!)
 * n    = lengte van 'C'
 * ncol = aantal kolommen in LG-kaart
 * nrow = aantal rijen in LG-kaart
 *
 * UITVOER:
 *
 * Een vector met lengte n en van type INTEGER.
 *
 ***********************************************************************/
{
    double *tmp;    // tijdelijke vector voor volle LG kaart
    double code;    // code op basis van LG waarden in focal area
    int i, k;       // iteratoren
    int index;
    double *xlg = REAL(LG);
    int *xc = INTEGER(C);
    int *xn = INTEGER(n), *xncol = INTEGER(ncol), *xnrow = INTEGER(nrow);
    int m = *xncol * *xnrow;
    int focal[9] = {-(*xncol+1), -*xncol, -(*xncol-1), -1, 0, 1, *xncol-1, *xncol, *xncol+1};

    tmp = Calloc(m,double);

    for (i = 0; i < *xn; i++) 
    {
        if (!ISNA(xlg[i]))
        {
            tmp[xc[i]] = xlg[i];
        }
    }

    SEXP HET;
    PROTECT(HET=allocVector(INTSXP,*xn));
    int *het = INTEGER(HET);

    for (i = 0; i < *xn; i++) 
    {
        if (!ISNA(xlg[i])) 
        {
            code = 0;
            for (k = 0; k < 9; k++)
            {
                index = xc[i] + focal[k];
                if (!(index < 1 || index > m))
                {
                    code += pow(10.0, tmp[index-1]);
                }
            }
            het[i] = code2het(code);
        } 
        else 
        {
            het[i] = NA_INTEGER;
        }
    }

    Free(tmp);
    UNPROTECT(1);
    return(HET);
}
示例#21
0
文件: RArcInfo.c 项目: cran/RArcInfo
SEXP get_cnt_data(SEXP directory, SEXP coverage, SEXP filename) 
{
	int i,j,n, *ilabel;
	void **pdata;
	char pathtofile[PATH];
	AVCCnt *reg;
	AVCBinFile *file;
	SEXP *table, label, aux;


	strcpy(pathtofile, CHAR(STRING_ELT(directory,0)));
	complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)),1);/*FIXME*/

	if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileCNT)))
		error("Error opening file");

	n=0;

	while(AVCBinReadNextCnt(file)){n++;}

	Rprintf("Number of CENTROIDS:%d\n",n);

	table=calloc(4, sizeof(SEXP));
	pdata=calloc(4,sizeof(void *));

	PROTECT(table[0]=NEW_INTEGER(n));
	pdata[0]=INTEGER(table[0]);

	PROTECT(table[1]=NEW_NUMERIC(n));
	pdata[1]=REAL(table[1]);

	PROTECT(table[2]=NEW_NUMERIC(n));
	pdata[2]=REAL(table[2]);

	PROTECT(table[3]=NEW_INTEGER(n));
	pdata[3]=INTEGER(table[3]);

	PROTECT(label=NEW_LIST(n));

	if(AVCBinReadRewind(file))
		error("Rewind");

	for(i=0;i<n;i++)
	{
		
		if(!(reg=(AVCCnt*)AVCBinReadNextCnt(file)))
			error("Error while reading register");

		((int *)pdata[0])[i]=reg->nPolyId;

		((double *)pdata[1])[i]=reg->sCoord.x;
		((double *)pdata[2])[i]=reg->sCoord.y;

		((int *)pdata[3])[i]=reg->numLabels;

		SET_VECTOR_ELT(label,i,NEW_INTEGER(reg->numLabels));
		ilabel=INTEGER(VECTOR_ELT(label,i));
		if(reg->numLabels >0)
		{
			for(j=0;j<reg->numLabels;j++)
			{
/*				printf("%d\n", reg->panLabelIds[j]);*/
				ilabel[j]=reg->panLabelIds[j];
			}
		}

	}


	PROTECT(aux=NEW_LIST(5));

	for(i=0;i<4;i++)
		SET_VECTOR_ELT(aux, i, table[i]);

	SET_VECTOR_ELT(aux, 4, label);

	UNPROTECT(6);

	free(table);
	free(pdata);

	return aux;
}
示例#22
0
文件: util.c 项目: cran/slam
SEXP _match_matrix(SEXP x, SEXP y, SEXP _nm) {
    if (TYPEOF(x) != INTSXP)
	error("'x' not integer");
    int nr, nc;
    SEXP r;

    if (!isMatrix(x))
	error("'x' not a matrix");
    r = getAttrib(x, R_DimSymbol);

    nr = INTEGER(r)[0];
    nc = INTEGER(r)[1];

    int ny = 0, 
	nm = NA_INTEGER;

    if (!isNull(y)) {
	if (TYPEOF(y) != INTSXP)
	    error("'y' not integer");
	if (!isMatrix(y))
	    error("'y' not a matrix");

	r = getAttrib(y, R_DimSymbol);

	ny = INTEGER(r)[0];
	if (nc != INTEGER(r)[1])
	    error("'x, y' number of columns don't match");

	if (!isNull(_nm)) {
	    if (TYPEOF(_nm) != INTSXP)
		error("'nm' not integer");
	    if (LENGTH(_nm))
		nm = INTEGER(_nm)[0];
	}
    }

    // Initialize hash table.
    int hk, k, n;
    SEXP ht;

    if (nr > 1073741824)
	error("size %d too large for hashing", nr);
    k  = 2 * nr;
    n  = 2;
    hk = 1;
    while (k > n) {
	n  *= 2;
	hk += 1;
    }
    ht = PROTECT(allocVector(INTSXP, n));
    for (k = 0; k < n; k++)
	INTEGER(ht)[k] = -1;

    // Match.
    SEXP s;
    r = PROTECT(allocVector(VECSXP, 2));
    SET_VECTOR_ELT(r, 0, (s = allocVector(INTSXP, nr)));

    n = 0;
    for (k = 0; k < nr; k++) {
	int j = _ihadd(INTEGER(x), nr, nc, k, INTEGER(x), nr, ht, hk);
	if (j > -1)
	    INTEGER(s)[k] = INTEGER(s)[j];
	else {
	    n++;
	    INTEGER(s)[k] = n;
	}
    }

    if (!isNull(y)) {
	SEXP t;
	SET_VECTOR_ELT(r, 1, (t = allocVector(INTSXP, ny)));
	
	for (k = 0; k < ny; k++) {
	    int j = _ihadd(INTEGER(y), ny, nc, k, INTEGER(x), nr, ht, hk);
	    if (j > -1)
		INTEGER(t)[k] = INTEGER(s)[j];
	    else 
		INTEGER(t)[k] = nm;
	}

	UNPROTECT(2);
	return r;
    }

    // Unique.

    SEXP t;
    SET_VECTOR_ELT(r, 1, (t = allocVector(INTSXP, n)));

    n = 1;
    for (k = 0; k < nr; k++)
	if (INTEGER(s)[k] == n) {
	    INTEGER(t)[n - 1] = k + 1;
	    n++;
	}

    UNPROTECT(2);
    return r;
}
示例#23
0
文件: RArcInfo.c 项目: cran/RArcInfo
SEXP get_table_data(SEXP infodir, SEXP tablename) 
{
	int i,j,n;
	char pathtoinfodir[PATH];
	void **pdata;
	AVCTableDef *tabledef;
	AVCField *reg;
	AVCBinFile *file;
	SEXP *table,aux;

	strcpy(pathtoinfodir, CHAR(STRING_ELT(infodir,0)));
	complete_path(pathtoinfodir, "", 1);

	if(!(file=AVCBinReadOpen(pathtoinfodir,CHAR(STRING_ELT(tablename,0)),AVCFileTABLE)))
	{
		error("Couldn't open table file\n");
	}

	n=0;

	while(AVCBinReadNextTableRec(file)){n++;}

	AVCBinReadRewind(file);


	tabledef=(file->hdr).psTableDef;

	table=calloc(tabledef->numFields, sizeof(SEXP));
	pdata=calloc(tabledef->numFields, sizeof(void *));


	for(i=0;i<tabledef->numFields;i++)
        {
/*printf("%d %d %d\n",i,j,tabledef->pasFieldDef[j].nType1);*/
		switch(tabledef->pasFieldDef[i].nType1)
		{
			case 1:
			case 2: PROTECT(table[i]=NEW_STRING(n));break;

			case 3: PROTECT(table[i]=NEW_INTEGER(n));
				pdata[i]=(int *)INTEGER(table[i]);break;

			case 4: PROTECT(table[i]=NEW_NUMERIC(n));
				pdata[i]=(double *)REAL(table[i]);break;
                                
			case 5: PROTECT(table[i]=NEW_INTEGER(n));
				pdata[i]=(int *)INTEGER(table[i]);break;

			case 6: PROTECT(table[i]=NEW_NUMERIC(n));
				pdata[i]=(double *)REAL(table[i]);break;
		}
	}		


	for(i=0;i<n;i++)
	{
		reg=AVCBinReadNextTableRec(file);

		for(j=0;j<tabledef->numFields;j++)
		{
/*			printf("%d %d %d\n",i,j,tabledef->pasFieldDef[j].nType1);*/
			switch(tabledef->pasFieldDef[j].nType1)
			{
				case 1: 
				case 2:
	SET_STRING_ELT(table[j],i, COPY_TO_USER_STRING(reg[j].pszStr)); 
				break;

				case 3:
				((int *)pdata[j])[i]=atoi(reg[j].pszStr);
				break;

				case 4:
				((double *)pdata[j])[i]=atof(reg[j].pszStr);
				break;

				case 5:
				if(reg[j].nInt16!=0)/*Single precision*/
					((int *)pdata[j])[i]=reg[j].nInt16;
				else/*Default and double precision*/
					((int *)pdata[j])[i]=reg[j].nInt32;
				break;
				
				case 6:
				if(reg[j].fFloat!=0)/*Single precision*/
					((double *)pdata[j])[i]=reg[j].fFloat;
				else/*Default and double precision*/
					((double *)pdata[j])[i]=reg[j].dDouble;
				break;
			}
		}
	}

	PROTECT(aux=NEW_LIST(tabledef->numFields));

	for(i=0;i<tabledef->numFields;i++)
		SET_VECTOR_ELT(aux, i, table[i]);

	UNPROTECT(1+tabledef->numFields);

	free(table);
	free(pdata);

	return aux;
}
示例#24
0
文件: util.c 项目: cran/slam
SEXP _ini_array(SEXP d, SEXP p, SEXP v, SEXP s) {
    if (TYPEOF(d) != INTSXP ||
	TYPEOF(p) != INTSXP ||
	TYPEOF(s) != INTSXP)
	error("'d, p, s' not integer");
    int n, m;
    SEXP r, dd;

    if (!isVector(v))
	error("'v' not a vector");
    if (isMatrix(p)) {
	r = getAttrib(p, R_DimSymbol);
	n = INTEGER(r)[0];
	if (n != LENGTH(v))
	    error("'p' and 'v' do not conform");
	m = INTEGER(r)[1];
	if (m != LENGTH(d))
	    error("'p' and 'd' do not conform");

	r = PROTECT(allocArray(TYPEOF(v), d));
    } else {
	n = LENGTH(p);
	if (n != LENGTH(v))
	    error("'p' and 'v' do not conform");
	m = 1;
	if (m != LENGTH(d))
	    error("'p' and 'd' do not conform");

	r = PROTECT(allocVector(TYPEOF(v), INTEGER(d)[0]));
    }
    switch(TYPEOF(v)) {
	case LGLSXP:
	case INTSXP:
	    memset(INTEGER(r), 0, sizeof(int) * LENGTH(r));
	    break;
	case REALSXP:
	    memset(REAL(r), 0, sizeof(double) * LENGTH(r));
	    break;
	case RAWSXP:
	    memset(RAW(r), 0, sizeof(char) * LENGTH(r));
	    break;
	case CPLXSXP:
	    memset(COMPLEX(r), 0, sizeof(Rcomplex) * LENGTH(r));
	    break;
	case EXPRSXP:
	case VECSXP:
	    for (int i = 0; i < LENGTH(r); i++)
		SET_VECTOR_ELT(r, i, R_NilValue);
	    break;
	case STRSXP:
	    for (int i = 0; i < LENGTH(r); i++)
		SET_STRING_ELT(r, i, R_BlankString);
	    break;
	default:
	    error("type of 'v' not supported");
    }

    if (m > 2) {
	dd = PROTECT(duplicate(d));
	for (int i = 1; i < m - 1; i++)
	    INTEGER(dd)[i] *= INTEGER(dd)[i-1];
    } else
	dd = d;

    for (int i = 0; i < LENGTH(s); i++) {
	int k = INTEGER(s)[i];
	if (k < 1 || k > n)
	    error("'s' invalid");
	k--;
	int h = k;
	int l = INTEGER(p)[k];
	if (l < 1 || l > INTEGER(d)[0])
	    error("'p' invalid");
	l--;
	for (int j = 1; j < m; j++) {
	    k += n;
	    int ll = INTEGER(p)[k];
	    if (ll < 1 || ll > INTEGER(d)[j])
		error("'p' invalid");
	    ll--;
	    l += INTEGER(dd)[j - 1] * ll;
	}
	switch(TYPEOF(v)) {
	    case LGLSXP:
	    case INTSXP:
		INTEGER(r)[l] = INTEGER(v)[h];
		break;
	    case REALSXP:
		REAL(r)[l] = REAL(v)[h];
		break;
	    case RAWSXP:
		RAW(r)[l] = RAW(v)[h];
		break;
	    case CPLXSXP:
		COMPLEX(r)[l] = COMPLEX(v)[h];
		break;
	    case EXPRSXP:
	    case VECSXP:
		SET_VECTOR_ELT(r, l, VECTOR_ELT(v, h));
		break;
	    case STRSXP:
		SET_STRING_ELT(r, l, STRING_ELT(v, h));
		break;
	    default:
		error("type of 'v' not supported");
	}

    }

    UNPROTECT(1 + (m > 2));
    return r;
}
示例#25
0
/* par fn gr options */
SEXP optimhess(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP par, fn, gr, options, tmp, ndeps, ans;
    OptStruct OS;
    int npar, i , j;
    double *dpar, *df1, *df2, eps;

    args = CDR(args);
    OS = (OptStruct) R_alloc(1, sizeof(opt_struct));
    OS->usebounds = 0;
    OS->R_env = rho;
    par = CAR(args);
    npar = LENGTH(par);
    OS->names = getAttrib(par, R_NamesSymbol);
    args = CDR(args); fn = CAR(args);
    if (!isFunction(fn)) error(_("'fn' is not a function"));
    args = CDR(args); gr = CAR(args);
    args = CDR(args); options = CAR(args);
    OS->fnscale = asReal(getListElement(options, "fnscale"));
    tmp = getListElement(options, "parscale");
    if (LENGTH(tmp) != npar)
	error(_("'parscale' is of the wrong length"));
    PROTECT(tmp = coerceVector(tmp, REALSXP));
    OS->parscale = vect(npar);
    for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i];
    UNPROTECT(1);
    PROTECT(OS->R_fcall = lang2(fn, R_NilValue));
    PROTECT(par = coerceVector(par, REALSXP));
    if (!isNull(gr)) {
	if (!isFunction(gr)) error(_("'gr' is not a function"));
	PROTECT(OS->R_gcall = lang2(gr, R_NilValue));
    } else {
	PROTECT(OS->R_gcall = R_NilValue); /* for balance */
    }
    ndeps = getListElement(options, "ndeps");
    if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length"));
    OS->ndeps = vect(npar);
    PROTECT(ndeps = coerceVector(ndeps, REALSXP));
    for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i];
    UNPROTECT(1);
    PROTECT(ans = allocMatrix(REALSXP, npar, npar));
    dpar = vect(npar);
    for (i = 0; i < npar; i++)
	dpar[i] = REAL(par)[i] / (OS->parscale[i]);
    df1 = vect(npar);
    df2 = vect(npar);
    for (i = 0; i < npar; i++) {
	eps = OS->ndeps[i]/(OS->parscale[i]);
	dpar[i] = dpar[i] + eps;
	fmingr(npar, dpar, df1, (void *)OS);
	dpar[i] = dpar[i] - 2 * eps;
	fmingr(npar, dpar, df2, (void *)OS);
	for (j = 0; j < npar; j++)
	    REAL(ans)[i * npar + j] = (OS->fnscale) * (df1[j] - df2[j])/
		(2 * eps * (OS->parscale[i]) * (OS->parscale[j]));
	dpar[i] = dpar[i] + eps;
    }
    // now symmetrize
    for (i = 0; i < npar; i++) 
	for (j = 0; j < i; j++) {
	    double tmp =
		0.5 * (REAL(ans)[i * npar + j] + REAL(ans)[j * npar + i]);
	    REAL(ans)[i * npar + j] = REAL(ans)[j * npar + i] = tmp;
	}
    SEXP nm = getAttrib(par, R_NamesSymbol);
    if(!isNull(nm)) {
	SEXP dm;
	PROTECT(dm = allocVector(VECSXP, 2));
	SET_VECTOR_ELT(dm, 0, duplicate(nm));
	SET_VECTOR_ELT(dm, 1, duplicate(nm));
	setAttrib(ans, R_DimNamesSymbol, dm);
	UNPROTECT(1);
    }
    UNPROTECT(4);
    return ans;
}
示例#26
0
/*
   Given a minc filename, return a list containing:
   (1) the dimension names
   (2) the dimension sizes
   (3) and much, much more
   */
SEXP get_volume_info(SEXP filename) {

    mihandle_t          minc_volume;
	midimhandle_t		*dimensions;
	miclass_t			volume_class;
	mitype_t			volume_type;
	
	int					result, i;
	int					n_dimensions;
	int					n_protects, list_index;
	int					n_frames;
	
// variables to hold dim-related info
	misize_t				dim_sizes[MI2_MAX_VAR_DIMS];
	double				dim_starts[MI2_MAX_VAR_DIMS];
	double				dim_steps[MI2_MAX_VAR_DIMS];
	double				time_offsets[MAX_FRAMES];
	double				time_widths[MAX_FRAMES];
	char 				*dim_name;
	char 				*dim_units;
	char 				*space_type;
	Rboolean			time_dim_exists;
	static char *dimorder3d[] = { "zspace","yspace","xspace" };
	static char *dimorder4d[] = { "time", "zspace","yspace","xspace" };
	

	/* declare R datatypes  */
	SEXP rtnList, listNames;
	SEXP xDimSizes, xDimNames, xDimUnits, xDimStarts, xDimSteps, xTimeWidths, xTimeOffsets;



	// start ...
	if ( R_DEBUG_rmincIO ) Rprintf("get_volume_info: start ...\n");


	/* do some initialization */
	for (i=0; i < MI2_MAX_VAR_DIMS; ++i){					// set dim info to zeros
		dim_sizes[i] = 0;
		dim_starts[i] = 0;
		dim_steps[i] = 0;
	}

	// frame-related init
	time_dim_exists = FALSE;
	for (i=0; i < MAX_FRAMES; ++i) {
		time_offsets[i]=999.9;
		time_widths[i]=999.9;
	}
	n_frames = 0;

	n_protects = 0;								// counter of protected R variables



	/* init the return list (include list names) */
	PROTECT(rtnList=allocVector(VECSXP, R_RTN_LIST_LEN));
	PROTECT(listNames=allocVector(STRSXP, R_RTN_LIST_LEN));
	n_protects = n_protects +2;


	/* open the existing volume */
	result = miopen_volume(CHAR(STRING_ELT(filename,0)), MI2_OPEN_READ, &minc_volume);
	/* error on open? */
	if (result != MI_NOERROR) {
		error("Error opening input file: %s.\n", CHAR(STRING_ELT(filename,0)));
	}

	/* set the apparent order to something conventional */
	//	... first need to get the number of dimensions
	if ( miget_volume_dimension_count(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, &n_dimensions) != MI_NOERROR ){
		error("Error returned from miget_volume_dimension_count.\n");
	}
	// ... now set the order
	if ( R_DEBUG_rmincIO ) Rprintf("Setting the apparent order for %d dimensions ... ", n_dimensions);
	if ( n_dimensions == 3 ) {
		result = miset_apparent_dimension_order_by_name(minc_volume, 3, dimorder3d);
	} else if ( n_dimensions == 4 ) {
		result = miset_apparent_dimension_order_by_name(minc_volume, 4, dimorder4d);
	} else {
		error("Error file %s has %d dimensions and we can only deal with 3 or 4.\n", CHAR(STRING_ELT(filename,0)), n_dimensions);
	}
	if ( result != MI_NOERROR ) { 
		error("Error returned from miset_apparent_dimension_order_by_name while setting apparent order for %d dimensions.\n", n_dimensions); 
	}
	if ( R_DEBUG_rmincIO ) Rprintf("Done.\n");

	/* get the volume data class (the intended "real" values) */ 
	if ( miget_data_class(minc_volume, &volume_class) != MI_NOERROR ){
		error("Error returned from miget_data_class.\n");
	}
	/* append to return list ... */
	list_index = 0;
	SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(volume_class));
	SET_STRING_ELT(listNames, list_index, mkChar("volumeDataClass"));


	/* print the volume data type (as it is actually stored in the volume) */
	if ( miget_data_type(minc_volume, &volume_type) != MI_NOERROR ){
		error("Error returned from miget_data_type.\n");
	}
	/* append to return list ... */
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(volume_type));
	SET_STRING_ELT(listNames, list_index, mkChar("volumeDataType"));


	/* retrieve the volume space type (talairach, native, etc) */
	result = miget_space_name(minc_volume, &space_type);
	if ( result == MI_NOERROR ) { error("Error returned from miget_space_name.\n"); }
	/* append to return list ... */
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, mkString(space_type));
	SET_STRING_ELT(listNames, list_index, mkChar("spaceType"));


	/* retrieve the total number of dimensions in this volume */
	if ( miget_volume_dimension_count(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, &n_dimensions) != MI_NOERROR ){
		error("Error returned from miget_volume_dimension_count.\n");
	}
	/* append to return list ... */
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(n_dimensions));
	SET_STRING_ELT(listNames, list_index, mkChar("nDimensions"));


	/* load up dimension-related information */
	//
	/* first allocate the R variables */
	PROTECT( xDimSizes=allocVector(INTSXP,n_dimensions) );
	PROTECT( xDimNames=allocVector(STRSXP,n_dimensions) );
	PROTECT( xDimUnits=allocVector(STRSXP,n_dimensions) );
	PROTECT( xDimStarts=allocVector(REALSXP,n_dimensions) );
	PROTECT( xDimSteps=allocVector(REALSXP,n_dimensions) );
	n_protects = n_protects +5;

	/* next, load up the midimension struct for all dimensions*/
	dimensions = (midimhandle_t *) malloc( sizeof( midimhandle_t ) * n_dimensions );
	result = miget_volume_dimensions(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, MI_DIMORDER_APPARENT, n_dimensions, dimensions);
	// need to check against MI_ERROR, as "result" will contain nDimensions if OK
	if ( result == MI_ERROR ) { error("Error code(%d) returned from miget_volume_dimensions.\n", result); }


	/* get the dimension sizes for all dimensions */
	result = miget_dimension_sizes(dimensions, n_dimensions, dim_sizes);
	if ( result != MI_NOERROR ) { error("Error returned from miget_dimension_sizes.\n"); }
	/* add to R vector ... */
	for (i=0; i<n_dimensions; ++i){
		INTEGER(xDimSizes)[i] = dim_sizes[i];
	}
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, xDimSizes);
	SET_STRING_ELT(listNames, list_index, mkChar("dimSizes"));


	/* get the dimension START values for all dimensions */
	result = miget_dimension_starts(dimensions, MI_ORDER_FILE, n_dimensions, dim_starts);
	if ( result == MI_ERROR ) { error("Error returned from miget_dimension_starts.\n"); }
	/* add to R vector ... */
	for (i=0; i<n_dimensions; ++i){
		REAL(xDimStarts)[i] = dim_starts[i];
	}
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, xDimStarts);
	SET_STRING_ELT(listNames, list_index, mkChar("dimStarts"));


	/* get the dimension STEP values for all dimensions */
	result = miget_dimension_separations(dimensions, MI_ORDER_FILE, n_dimensions, dim_steps);
	if ( result == MI_ERROR ) { error("Error returned from miget_dimension_separations.\n"); }
	/* add to R vector ... */
	for (i=0; i<n_dimensions; ++i){
		REAL(xDimSteps)[i] = dim_steps[i];
	}
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, xDimSteps);
	SET_STRING_ELT(listNames, list_index, mkChar("dimSteps"));


	/* Loop over the dimensions to grab the remaining info ... */
	for( i=0; i < n_dimensions; ++i ){
	//
	/* get (and print) the dimension names for all dimensions*
	... remember that since miget_dimension_name calls strdup which, in turn,
	... calls malloc to get memory for the new string -- we need to call "mifree" on
	... our pointer to release that memory.  */
		result = miget_dimension_name(dimensions[i], &dim_name);
		
		// do we have a time dimension?
		if ( !strcmp(dim_name, "time") ) { 
			time_dim_exists = TRUE;
			n_frames = ( time_dim_exists ) ? dim_sizes[0] : 0;
		}
		
		// store the dimension name and units
		SET_STRING_ELT(xDimNames, i, mkChar(dim_name));
		mifree_name(dim_name);
		
		result = miget_dimension_units(dimensions[i], &dim_units);
		SET_STRING_ELT(xDimUnits, i, mkChar(dim_units));
		mifree_name(dim_units);
		
	}
	/* add number of frames to return list */
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(n_frames));
	SET_STRING_ELT(listNames, list_index, mkChar("nFrames"));
	
	// add dim names to return list
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, xDimNames);
	SET_STRING_ELT(listNames, list_index, mkChar("dimNames"));
	// add dim units
	list_index++;
	SET_VECTOR_ELT(rtnList, list_index, xDimUnits);
	SET_STRING_ELT(listNames, list_index, mkChar("dimUnits"));


	/* get the dimension OFFSETS values for the TIME dimension */
	if ( time_dim_exists ) {

		PROTECT( xTimeOffsets=allocVector(REALSXP,n_frames) );
		n_protects++;
		result = miget_dimension_offsets(dimensions[0], n_frames, 0, time_offsets);
		if ( result == MI_ERROR ) { error("Error returned from miget_dimension_offsets.\n"); }
		/* add to R vector ... */
		for (i=0; i < n_frames; ++i) {
			REAL(xTimeOffsets)[i] = time_offsets[i];
//			if (R_DEBUG_rmincIO) Rprintf("Time offset[%d] =  %g\n", i, time_offsets[i]);
		}
		list_index++;
		SET_VECTOR_ELT(rtnList, list_index, xTimeOffsets);
		SET_STRING_ELT(listNames, list_index, mkChar("timeOffsets"));

		/* get the dimension WIDTH values for the TIME dimension */
		PROTECT( xTimeWidths=allocVector(REALSXP,n_frames) );
		n_protects++;
	
		result = miget_dimension_widths(dimensions[0], MI_ORDER_FILE, n_frames, 0, time_widths);
		if ( result == MI_ERROR ) { error("Error returned from miget_dimension_widths.\n"); }
		/* add to R vector ... */
		for (i=0; i<n_frames; ++i) {
			REAL(xTimeWidths)[i] = time_widths[i];
//			if (R_DEBUG_rmincIO) Rprintf("Time width[%d] =  %g\n", i, time_widths[i]);
		}
		list_index++;
		SET_VECTOR_ELT(rtnList, list_index, xTimeWidths);
		SET_STRING_ELT(listNames, list_index, mkChar("timeWidths"));
	}



	// free heap memory
	free(dimensions);


	/* close volume */
	miclose_volume(minc_volume);


	/* attach the list component names to the list */
	setAttrib(rtnList, R_NamesSymbol, listNames);


	/* remove gc collection protection */
	UNPROTECT(n_protects);

   /* return */
	if ( R_DEBUG_rmincIO ) Rprintf("get_volume_info: returning ...\n");
   return(rtnList);
}
	SEXP additiveFunctionValues(SEXP reachIDs, SEXP binaryIDs, SEXP proportionalInfluences, SEXP netIDs)
	{
		unsigned int nReachIDs = LENGTH(reachIDs);
		unsigned int nBinaryIDs = LENGTH(binaryIDs);
		unsigned int nProportionalInfluences = LENGTH(proportionalInfluences);
		unsigned int nNetIDs = LENGTH(netIDs);
		
		typedef std::map<int, NetworkPtr> NetworksMapType;
		std::vector<char*> allocatedStrings;
		NetworksMapType networks;
		
		if(nReachIDs != nBinaryIDs)
		{
			error("The number of input reach ID values must equal the number of input binary ID values\n");
			return R_NilValue;			
		}
		if(nBinaryIDs != nProportionalInfluences)
		{
			error("The number of input proportional influence values must equal the number of input binary ID values\n");
			return R_NilValue;			
		}
		if(nProportionalInfluences != nNetIDs)
		{
			error("The number of input proportional influence values must equal the number of input network ID values\n");
			return R_NilValue;
		}
		if(TYPEOF(reachIDs) != INTSXP)
		{
			error("Input reach ID values must be integers\n");
			return R_NilValue;
		}
		if(TYPEOF(binaryIDs) != STRSXP)
		{
			error("Input binary ID values must be character strings\n");
			return R_NilValue;
		}
		if(TYPEOF(proportionalInfluences) != REALSXP)
		{
			error("Input proportional influence values must be floating point numeric\n");
			return R_NilValue;
		}
		if(TYPEOF(netIDs) != INTSXP)
		{
			error("Input network ID values must be integers\n");
			return R_NilValue;
		}
		int* networkIDs_pointer = INTEGER(netIDs);
		int* rids_pointer = INTEGER(reachIDs);
		double* proportionalInfluences_pointer = REAL(proportionalInfluences);
		//the returned value
		SEXP result = R_NilValue;
		std::vector<int> sortedNetworkIDs(networkIDs_pointer, networkIDs_pointer + nNetIDs);
		
		std::sort(sortedNetworkIDs.begin(), sortedNetworkIDs.end());
		std::vector<int>::iterator unique_end = std::unique(sortedNetworkIDs.begin(), sortedNetworkIDs.end());
		
		//initialize an entry for every network. 
		for(std::vector<int>::iterator i = sortedNetworkIDs.begin(); i != unique_end; i++)
		{
			networks.insert(NetworksMapType::value_type(*i, NetworkPtr(new Network())));
		}
		bool hasError = false;	
		std::string errString;		
		//construct tree data structure
		for(unsigned int i = 0; i < nNetIDs; i++)
		{
			int networkID = networkIDs_pointer[i];
			const char* binaryRepresentation = CHAR(STRING_ELT(binaryIDs, i));
			int representationLength = strlen(binaryRepresentation);
			//if there are spaces at the beginning or end we need to trim the string. This means we need to malloc our own copy, so track this in allocatedStrings
			if(isspace(binaryRepresentation[0]) || isspace(binaryRepresentation[representationLength-1]))
			{
				const char* start = binaryRepresentation;
				while(isspace(*start) && *start != 0) start++;
				if(*start == 0)
				{
					hasError = true;
					errString = "Blank binary ID detected";
					goto cleanup;
				}
				else
				{	
					const char* end = binaryRepresentation + representationLength - 1;
					while(isspace(*end)) end--;
					representationLength = end - start + 1;
					char* representation = new char[representationLength+1];
					memcpy(representation, start, representationLength);
					//add null terminator
					representation[representationLength] = 0;
					allocatedStrings.push_back(representation);
					binaryRepresentation = representation;
				}
			}
			NetworkPtr currentNetwork = networks[networkID];
						
			NodePtr newNode = NodePtr(new Node());
			newNode->rid = rids_pointer[i];
			newNode->index = i;
			newNode->binaryID = binaryRepresentation;
			newNode->proportionalInfluence = proportionalInfluences_pointer[i];
			
			currentNetwork->allNodes.push_back(newNode);
			if(currentNetwork->binaryRepresentationsToNodes.find(binaryRepresentation) != currentNetwork->binaryRepresentationsToNodes.end())
			{
				hasError = true;
				errString = "Duplicate binary IDs found";
				goto cleanup;
			}
			currentNetwork->binaryRepresentationsToNodes.insert(Network::BinaryLookupMap::value_type(binaryRepresentation, newNode));
			
			//if it's the root don't bother looking for parents
			if(std::strcmp(binaryRepresentation, "1") != 0)
			{
				char* parentBinaryID = strdup(binaryRepresentation);
				parentBinaryID[representationLength-1] = 0;
				Network::BinaryLookupMap::iterator findParent = currentNetwork->binaryRepresentationsToNodes.find(parentBinaryID);
				if(findParent != currentNetwork->binaryRepresentationsToNodes.end())
				{
					//child one or child two?
					if(binaryRepresentation[representationLength-1] == '0')
					{
						findParent->second->child1 = newNode;
					}
					else
					{
						findParent->second->child2 = newNode;
					}
					newNode->parent = findParent->second;
				}
				free(parentBinaryID);
			}
			//if it's the root node, store it
			else 
			{
				currentNetwork->rootNode = newNode;
			}
			char* childID = new char[representationLength+2];
			strcpy(childID, binaryRepresentation);
			childID[representationLength] = '0';
			childID[representationLength+1] = 0;
			Network::BinaryLookupMap::iterator possibleChild1 = currentNetwork->binaryRepresentationsToNodes.find(childID);
			if(possibleChild1 != currentNetwork->binaryRepresentationsToNodes.end())
			{
				newNode->child1 = possibleChild1->second;
				possibleChild1->second->parent= newNode;
			}
			
			childID[representationLength] = '1';
			Network::BinaryLookupMap::iterator possibleChild2 = currentNetwork->binaryRepresentationsToNodes.find(childID);
			if(possibleChild2 != currentNetwork->binaryRepresentationsToNodes.end())
			{
				newNode->child2 = possibleChild2->second;
				possibleChild2->second->parent = newNode;
			}
			delete[] childID;
		}
		//normalize proportional influence values so that if we have two child nodes then their proportional influence values sum to 1
		for(NetworksMapType::iterator i = networks.begin(); i != networks.end(); i++)
		{
			NetworkPtr currentNetwork = i-> second;
			for(std::vector<NodePtr>::iterator j = currentNetwork->allNodes.begin(); j != currentNetwork->allNodes.end(); j++)
			{
				//if it's not a terminal node, normalize. 
				if((*j)->child1 && (*j)->child2)
				{
					double sum = (*j)->child1->proportionalInfluence + (*j)->child2->proportionalInfluence;
					(*j)->child1->proportionalInfluence /= sum;
					(*j)->child2->proportionalInfluence /= sum;
				}
				else if((*j)->child1)
				{
					(*j)->child1->proportionalInfluence = 1;
				}
				else if((*j)->child2)
				{
					(*j)->child2->proportionalInfluence = 1;
				}
				if(!(*j)->parent)
				{
					(*j)->proportionalInfluence = 1;
				}
			}
		}	
		//storage for results
		PROTECT(result = allocVector(REALSXP, nNetIDs));
		{
			double* result_pointer = REAL(result);
			//this next chunk is basically a by-hand tree-traversal algorithm. Ugly, but we need to limit any dependencies
			for(NetworksMapType::iterator i = networks.begin(); i != networks.end(); i++)
			{
				NetworkPtr currentNetwork = i->second;
				NodePtr currentNode = currentNetwork->rootNode;
				if(!currentNode)
				{
					std::stringstream ss;
					ss << "Root node not found for network "<< i->first;
					errString = ss.str();
					hasError = true;
					goto cleanup;
				}
				currentNode->functionalValue = currentNode->proportionalInfluence;
				result_pointer[currentNode->index] = currentNode->proportionalInfluence;
				if(fabs(result_pointer[currentNode->index]) > 1)
				{
					errString = "Internal error, additive function value was out of range";
					hasError = true;
					goto cleanup;
				}
				do
				{
					while(currentNode->child1 || (!currentNode->child1 && currentNode->child2))
					{
						if(currentNode->child1)
						{
							currentNode = currentNode->child1;
						}
						else
						{
							currentNode = currentNode->child2;
						}
						currentNode->functionalValue = currentNode->proportionalInfluence * currentNode->parent->functionalValue;
						result_pointer[currentNode->index] = currentNode->functionalValue;
						if(fabs(result_pointer[currentNode->index]) > 1)
						{
							errString = "Internal error, additive function value was out of range";
							hasError = true;
							goto cleanup;
						}
					}
					do
					{
						if(!currentNode->parent) 
						{
							//we've finished for this network, so break out to the end of the for loop
							goto finish;
						}
						if(currentNode->parent->child1 && currentNode->parent->child1 == currentNode) 
						{
							if(currentNode->parent->child2)
							{
								currentNode = currentNode->parent->child2;
								currentNode->functionalValue = currentNode->proportionalInfluence * currentNode->parent->functionalValue;
								result_pointer[currentNode->index] = currentNode->functionalValue;
								if(fabs(result_pointer[currentNode->index]) > 1)
								{
									errString = "Internal error, additive function value was out of range";
									hasError = true;
									goto cleanup;
								}
								//we've finished this loop but we want to keep going on this network. So just break
								break;
							}
							else currentNode = currentNode->parent;
						}
						else currentNode = currentNode->parent;
					}
					while(true);
				}
				while(true);
			finish:
				;
			}
		}
		UNPROTECT(1);
	cleanup:
		//cleanup code goes in a seperate loop, in case we break out of the previous one. 
		for(NetworksMapType::iterator i = networks.begin(); i != networks.end(); i++)
		{
			NetworkPtr currentNetwork = i->second;
			//clean everything up
			for(std::vector<NodePtr>::iterator j = currentNetwork->allNodes.begin(); j != currentNetwork->allNodes.end(); j++)
			{
				(*j)->parent.reset();
				(*j)->child1.reset();
				(*j)->child2.reset();
			}
			currentNetwork->allNodes.clear();
			currentNetwork->rootNode.reset();
		}
		for(std::vector<char*>::iterator i = allocatedStrings.begin(); i != allocatedStrings.end(); i++) delete[] *i;
		if(hasError)
		{
			error(errString.c_str());
			return R_NilValue;
		}
		return result;
	}
示例#28
0
文件: lik4.c 项目: cran/SCEPtERbinary
SEXP lik4bin(SEXP data, SEXP star, SEXP sigma, SEXP thr, SEXP var, SEXP power, SEXP restringi, SEXP tsp)
{
  double *Pdata, *Psigma, *Pstar, Pres[22], *Rres, *wstar, *age1, *age2;
  double *Teff, *logg, *z, *M, *R, *Dni, *nimax, *logage, *pcage;
  double Vthr, maxL, maxL1, maxL2, lmult, EXP, rpcage;
  long nrow, ncol, count;

  double sq2pi, chi[NVAR], locsigma[NVAR], chi2, mult, L, mass, 
    radius, lt, ltnlog;;
  double sTeffP, sTeffM, time1, time2;
  SEXP res, dm, sel;
  long i, j, nres, nres1, nres2, DIM, start, n, startT, stopT, up, low;
  int ii, norun, nstar, *Psel, *Pvar, restr;
  DATA5 *d, *d1, *d2, *d3, *d4;
  long lb, ub;
  double t_spread; // max diff. in age

  // cast and pointers 
  PROTECT(data = AS_NUMERIC(data));
  PROTECT(star = AS_NUMERIC(star));
  PROTECT(sigma = AS_NUMERIC(sigma));
  PROTECT(thr = AS_NUMERIC(thr));
  PROTECT(var = AS_INTEGER(var));
  PROTECT(power = AS_NUMERIC(power));
  PROTECT(restringi = AS_INTEGER(restringi));
  PROTECT(tsp = AS_NUMERIC(tsp));

  Pdata = NUMERIC_POINTER(data);
  Pstar = NUMERIC_POINTER(star);
  Psigma = NUMERIC_POINTER(sigma);
  Vthr = NUMERIC_VALUE(thr);
  Pvar = INTEGER_POINTER(var);
  EXP = NUMERIC_VALUE(power);
  restr = NUMERIC_VALUE(restringi);
  t_spread = NUMERIC_VALUE(tsp);

  // sqrt ( 2 * pi )
  sq2pi = 2.506628274631000;

  // dataset dimensions
  nrow = INTEGER(GET_DIM(data))[0];
  ncol = INTEGER(GET_DIM(data))[1];

  // column pointers
  // data are column ordered!
  Teff = Pdata;
  logg = Pdata+nrow;
  z = Pdata+2*nrow;
  Dni = Pdata+3*nrow;
  nimax = Pdata+4*nrow;
  M = Pdata+5*nrow;
  R = Pdata+6*nrow;
  logage = Pdata+7*nrow;
  pcage = Pdata+8*nrow;

  // vector for likelihood computations
  // 1 = include; 0 = exclude
  Psel = (int*)malloc(nrow*sizeof(int));

  for(nstar=0;nstar<2;nstar++) 
    {
      for(j=0;j<nrow;j++)
	Psel[j] = 0;

      wstar = &Pstar[(nstar)*9];

      // sigma scaling for Dni,nimax,M,R (it is a % in input)
      for(n=0;n<NVAR;n++)
	locsigma[n] = Psigma[n+NVAR*nstar];
      for(n=3;n<7;n++)
	locsigma[n] *= wstar[n];
      
      mult = 1;
      for(n=0;n<NVAR;n++)
	if(Pvar[n] == 1)
	  mult *= 1.0/(sq2pi * locsigma[n]);
      lmult = log(mult);

      // allowed Teff interval
      sTeffP = wstar[0] + Vthr*locsigma[0];
      sTeffM = wstar[0] - Vthr*locsigma[0];

      // ricerca righe con Teff minima e massima
      findrange(Teff, nrow, sTeffM, sTeffP, &startT, &stopT);
      if(startT == -1 || stopT == -1)
	{
	  free(Psel);
	  UNPROTECT(8);
	  return(R_NilValue);
	}

      // sel computation
      nres = 0;
      for(j=startT;j<=stopT;j++)
	{
	  for(ii=0;ii<NVAR;ii++)
	    chi[ii] = 0;
	  
	  if(Pvar[0] == 1)
	    chi[0] = (Teff[j] - wstar[0])/locsigma[0];
	  if(Pvar[1] == 1)
	    chi[1] = (logg[j] - wstar[1])/locsigma[1];
	  if(Pvar[2] == 1)
	    chi[2] = (z[j] - wstar[2])/locsigma[2];
	  if(Pvar[3] == 1)
	    chi[3] = (Dni[j] - wstar[3])/locsigma[3];
	  if(Pvar[4] == 1)
	    chi[4] = (nimax[j] - wstar[4])/locsigma[4];
	  if(Pvar[5] == 1)
	    chi[5] = (M[j] - wstar[5])/locsigma[5];
	  if(Pvar[6] == 1)
	    chi[6] = (R[j] - wstar[6])/locsigma[6];

	  norun = 0;
	  for(ii=0;ii<NVAR;ii++)
	    {
	      if(fabs(chi[ii]) >= Vthr)
		{
		  norun = 1;
		  break;
		}
	    }
	  
	  if( norun == 0 ) 
	    {
	      chi2 = 0;
	      for(ii=0;ii<NVAR;ii++)
		chi2 += chi[ii]*chi[ii];
	      if( restr == 1 ) 
		{
		  if(sqrt(chi2) <= 3 )
		    {
		      nres++;
		      Psel[j] = 1;
		    }
		}
	      else 
		{
		  nres++;
		  Psel[j] = 1;
		}
	    }
	}
      
      // no data! return
      if(nres == 0) 
	{
	  free(Psel);
	  UNPROTECT(8);
	  return(R_NilValue);
	}
      // init output matrix
      DIM = nres;
      if(nstar == 0)
	{
	  d1 = (DATA5 *)calloc(DIM+1, sizeof(DATA5));
	  d = d1;
	}
      else
	{
	  d2 = (DATA5 *)calloc(DIM+1, sizeof(DATA5));
	  d = d2;
	}
      
      // compute lik only if sel = 1
      nres = 0;
      maxL = 0;
      for(j=startT;j<=stopT;j++)
	{
	  if( Psel[j] == 1 ) 
	    {
	      for(ii=0;ii<NVAR;ii++)
		chi[ii] = 0;
	      
	      if(Pvar[0] == 1)
		chi[0] = (Teff[j] - wstar[0])/locsigma[0];
	      if(Pvar[1] == 1)
		chi[1] = (logg[j] - wstar[1])/locsigma[1];
	      if(Pvar[2] == 1)
		chi[2] = (z[j] - wstar[2])/locsigma[2];
	      if(Pvar[3] == 1)
		chi[3] = (Dni[j] - wstar[3])/locsigma[3];
	      if(Pvar[4] == 1)
		chi[4] = (nimax[j] - wstar[4])/locsigma[4];
	      if(Pvar[5] == 1)
		chi[5] = (M[j] - wstar[5])/locsigma[5];
	      if(Pvar[6] == 1)
		chi[6] = (R[j] - wstar[6])/locsigma[6];
	      
	      chi2 = 0;
	      for(n=0;n<NVAR;n++)
		chi2 += chi[n]*chi[n];
	      
	      // likelihood
	      L = mult * exp(-0.5*chi2);
	      if(L > maxL)
		maxL = L;
	      d[nres].L = L;
	      d[nres].M = M[j];
	      d[nres].R = R[j];
	      d[nres].logage = logage[j];
	      d[nres].pcage = pcage[j];
	      nres++;
	    }
	}
      if(nstar==0) 
	{
	  nres1 = nres;
	  maxL1 = maxL;
	}
      else
	{
	  nres2 = nres;
	  maxL2 = maxL;
	}
    }
  
   // independent estimates
  for(nstar=0;nstar<2;nstar++)
    {
      mass = radius = lt = ltnlog = rpcage = 0;
      count = 0;
      if(nstar==0)
	{
	  nres = nres1;
	  maxL = maxL1;
	  d = d1;
	}
      else
	{
	  nres = nres2;
	  maxL = maxL2;
	  d = d2;
	}
      
      // select only points with L >= 0.95 maxL
      for(j=0;j<nres;j++)
	{
	  if(d[j].L >= 0.95*maxL) 
	    {
	      mass += d[j].M;
	      radius += d[j].R;
	      lt += d[j].logage;
	      rpcage += d[j].pcage;
	      ltnlog += 1e-9*pow(10, d[j].logage);
	      count++;
	    }
	}
      mass /= (double)(count);
      radius /= (double)(count);
      lt /= (double)(count);
      ltnlog /= (double)(count);
      rpcage /= (double)(count);
     
      Pres[0+6*nstar] = mass;
      Pres[1+6*nstar] = radius;
      Pres[2+6*nstar] = lt;
      Pres[3+6*nstar] = ltnlog;
      Pres[4+6*nstar] = maxL;
      Pres[5+6*nstar] = rpcage;
    }

  // joint estimates
  qsort(d2, nres2, sizeof(DATA5), orderage);
  age2 = (double*)malloc(nres2*sizeof(double));
  age1 = (double*)malloc(nres1*sizeof(double));

  for(i=0;i<nres1;i++)
    age1[i] = 1e-9*pow(10, d1[i].logage);

  for(i=0;i<nres2;i++)
    age2[i] = 1e-9*pow(10, d2[i].logage);

  maxL = 0;
  for(j=0;j<nres1;j++)
    {
      findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub);
      // the joint estimate is impossible
      if(lb == -1 || ub == -1) continue;
      if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue;
      for(i=lb;i<=ub;i++)
	{
	  count++;
	  L = d1[j].L * d2[i].L;
	  if(L > maxL)
	    maxL = L;
	}
    }

  for(j=12;j<22;j++)
    Pres[j] = 0;
  
  count = 0;
  for(j=0;j<nres1;j++)
    {
      findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub);
      if(lb == -1 || ub == -1) continue;
      if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue;
      for(i=lb;i<=ub;i++)
	{
	  L = d1[j].L * d2[i].L;
	  if(L > 0.95*maxL)
	    {
	      
	      Pres[12] += d1[j].M;
	      Pres[13] += d1[j].R;
	      Pres[14] += d1[j].logage;
	      Pres[15] += age1[j];
	      
	      Pres[16] += d2[i].M;
	      Pres[17] += d2[i].R;
	      Pres[18] += d2[i].logage;
	      Pres[19] += age2[i];

	      Pres[21] += d1[j].pcage;

	      count++;
	    }
	}
    }
  
  Pres[20] = (double)count;

  for(j=12;j<20;j++)
    Pres[j] /= (double)(count);
  Pres[21] /= (double)(count);

  PROTECT( res = NEW_NUMERIC(22) );
  Rres = NUMERIC_POINTER(res);
  for(j=0;j<22;j++)
    Rres[j] = Pres[j];

  free(d1);
  free(d2);
  free(Psel);
  free(age1);
  free(age2);
  
  // exit
  UNPROTECT(9);
  return(res);
}
示例#29
0
文件: Grid-R.c 项目: rocanale/RElem
SEXP gridInGrid(SEXP Rptr){
  SEXP ans=PROTECT( allocVector(LGLSXP,1) );
  ElGridInGrid( toGrid(Rptr), (bool *)LOGICAL(ans) );
  UNPROTECT(1);
  return ans;
}
示例#30
0
文件: unique.time.c 项目: Glanda/xts
SEXP non_duplicates (SEXP x_, SEXP fromLast_) {
  int fromLast = asLogical(fromLast_),
      i, d=0,
      len   = length(x_);
  
  int *x_int;
  double *x_real;

  SEXP duplicates;
  int *duplicates_int;
  PROTECT(duplicates = allocVector(INTSXP, len)); /* possibly resize this */
  duplicates_int = INTEGER(duplicates);

  if(!fromLast) { /* keep first observation */
    duplicates_int[0] = ++d;
    switch(TYPEOF(x_)) {
      case INTSXP:
        x_int = INTEGER(x_);
        for(i=1; i < len-1; i++) {
          if( x_int[i-1] != x_int[i]) {
#ifdef DEBUG
            Rprintf("i=%i:  x[i-1]=%i, x[i]=%i\n",i,x_int[i-1],x_int[i]);
#endif
            duplicates_int[d++] = i+1;
          }
        }      
        break;
      case REALSXP:
        x_real = REAL(x_);
        for(i=1; i < len; i++) {
          /*
          if( x_real[i-1] == x_real[i])
            duplicates_int[d++] = (int)(-1*(i+1));
          */
          if( x_real[i-1] != x_real[i])
            duplicates_int[d++] = i+1;
        }      
        break;
      default:
        error("only numeric types supported");
        break;
    }
  } else {    /* keep last observation  */
    switch(TYPEOF(x_)) {
      case INTSXP:
        x_int = INTEGER(x_);
        for(i=1; i < len; i++) {
          if( x_int[i-1] != x_int[i])
            duplicates_int[d++] = i;
        }      
        break;
      case REALSXP:
        x_real = REAL(x_);
        for(i=1; i < len; i++) {
          if( x_real[i-1] != x_real[i])
            duplicates_int[d++] = i;
        }      
        break;
      default:
        error("only numeric types supported");
        break;
    }
    duplicates_int[d++] = len;
  }
  UNPROTECT(1);
  return(lengthgets(duplicates, d));
}