本文整理汇总了C++中UNPROTECT函数的典型用法代码示例。如果您正苦于以下问题：C++ UNPROTECT函数的具体用法？C++ UNPROTECT怎么用？C++ UNPROTECT使用的例子？那么, 这里精选的函数代码示例或许可以为您提供帮助。
在下文中一共展示了UNPROTECT函数的15个代码示例，这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞，您的评价将有助于系统推荐出更棒的C++代码示例。
示例1: minc2_apply
//.........这里部分代码省略.........
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: fmingr
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: gridLCM
SEXP gridLCM( SEXP Rptr){
SEXP ans= PROTECT( allocVector(INTSXP,1) );
ElGridLCM( toGrid(Rptr), INTEGER(ans) );
UNPROTECT(1);
return ans;
}示例4: get_txt_data
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: optim
/* 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 */
//.........这里部分代码省略.........
示例6: get_table_names
/*
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: get_lab_data
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: do_subset_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;
//.........这里部分代码省略.........
示例9: throw
virtual ~RObject() throw() { if(is_R) { UNPROTECT(1); } }示例10: mat_split
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;
//.........这里部分代码省略.........
示例11: spPPGLM
//.........这里部分代码省略.........
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: R_num_to_char
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: resamp_func_builtin_PPW
/*
* 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: superSubset
//.........这里部分代码省略.........
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: bn_recovery
//.........这里部分代码省略.........
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*/