SEXP null_to_na_(SEXP x) { SEXP na_vector = PROTECT(Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(na_vector, 0, NA_STRING); // One element for each row int n = Rf_length(x); for (int i = 0; i < n; ++i) { SEXP row = VECTOR_ELT(x, i); SEXP f = VECTOR_ELT(row, 0); int p = Rf_length(f); for (int j = 0; j < p; ++j) { SEXP val = VECTOR_ELT(f, j); if (Rf_isNull(val)) { SEXP v = PROTECT(Rf_allocVector(VECSXP, 1)); SET_VECTOR_ELT(v, 0, Rf_duplicate(na_vector)); SET_VECTOR_ELT(f, j, v); UNPROTECT(1); } else if (Rf_isNull(VECTOR_ELT(val, 0))) { SET_VECTOR_ELT(val, 0, Rf_duplicate(na_vector)); } } } UNPROTECT(1); return(x); }
SEXP R_makecartogram(SEXP r_pop, SEXP gridx, SEXP gridy, SEXP r_dims, SEXP blur) { int *dims; double **pop; int i, n; SEXP ans; dims = INTEGER(r_dims); /* Note that if we get an interrupt, this will not be freed! We may change cart.c to use R_alloc(). */ cart_makews(dims[0], dims[1]); pop = (double **) R_alloc(sizeof(double *), dims[0]); if(TYPEOF(r_pop) == VECSXP) { /* This leads to non-contiguous values. Not certain if this is * allowed in the cart.c code. */ for(i = 0; i < dims[0]; i++) { pop[i] = REAL(VECTOR_ELT(r_pop, i)); } } else { /* Given a numeric matrix, so just pull out the pointers to the beginning of each column. Since we are using the columns for the Y values, this gives us the form of a 2D array in C with pop[i] giving a vector/array of the y's. */ double *data = REAL(r_pop); for(i = 0; i < dims[0]; i++) { pop[i] = data + i * dims[1]; } } INTERRUPT cart_transform(pop, dims[0], dims[1]); PROTECT(ans = allocVector(VECSXP, 2)); SET_VECTOR_ELT(ans, 0, gridx = Rf_duplicate(gridx)); SET_VECTOR_ELT(ans, 1, gridy = Rf_duplicate(gridy)); INTERRUPT cart_makecart(REAL(gridx), REAL(gridy), Rf_length(gridx), dims[0], dims[1], REAL(blur)[0]); INTERRUPT cart_freews(dims[0], dims[1]); UNPROTECT(1); return(ans); }
/* -------------------------------------------------------------------------- */ SEXP fillHull(SEXP x) { SEXP res; int nprotect = 0; int nz; // check image validity validImage(x,0); nz = getNumberOfFrames(x, 0); int *dim=INTEGER(GET_DIM(x)); XYPoint size(dim[0], dim[1]); // return itself if nothing to do if (size.x <= 0 || size.y <= 0 || nz < 1) return x; // do fillHull PROTECT(res = Rf_duplicate(x)); nprotect++; if (IS_INTEGER(res)) { for (int i=0; i < nz; i++) _fillHullT<int>(&(INTEGER(res)[i*size.x*size.y]), size); } else if (IS_NUMERIC(res)) { for (int i=0; i < nz; i++) _fillHullT<double>(&(REAL(res)[i*size.x*size.y]), size); } UNPROTECT (nprotect); return res; }
/* -------------------------------------------------------------------------- */ SEXP floodFill(SEXP x, SEXP point, SEXP col, SEXP tol) { int i, nz, *dim; int nprotect=0; XYPoint pt; SEXP res; // check image validity validImage(x,0); nz = getNumberOfFrames(x, 0); dim = INTEGER(GET_DIM(x)); XYPoint size(dim[0], dim[1]); if (size.x <= 0 || size.y <= 0) error("image must have positive dimensions"); if (LENGTH(point) != 2*nz) error("point must have a size of two times the number of frames"); if (LENGTH(col) != nz) error("color must have the same size as the number of frames"); // initialize result PROTECT(res = Rf_duplicate(x)); nprotect++; // do the job over images for (i=0; i<nz; i++) { pt.x = INTEGER(point)[i]-1; pt.y = INTEGER(point)[nz+i]-1; if (IS_NUMERIC(res)) _floodFill<double>(&(REAL(res)[i*size.x*size.y]), size, pt, REAL(col)[i], REAL(tol)[0]); if (IS_INTEGER(res)) _floodFill<int>(&(INTEGER(res)[i*size.x*size.y]), size, pt, INTEGER(col)[i], REAL(tol)[0]); } UNPROTECT (nprotect); return res; }
/*----------------------------------------------------------------------- */ SEXP lib_erode_dilate (SEXP x, SEXP kernel, SEXP what, SEXP binary) { numeric resetTo, * tgt, * src, *kern, min, max; int nz, i, j, nprotect; int * dim; PointXY size, ksize, pt; SEXP res; validImage(x,0); validImage(kernel,0); /* value to reset the checked part t */ if ( INTEGER(what)[0] == DILATE ) resetTo = 1.0; /* checking background, reseting to 1 */ else resetTo = 0.0; /* checking foreground, reseting to 0 */ dim = INTEGER ( GET_DIM(x) ); size.x = dim[0]; size.y = dim[1]; nz = getNumberOfFrames(x,0); kern = REAL (kernel); ksize.x = INTEGER ( GET_DIM(kernel) )[0]; ksize.y = INTEGER ( GET_DIM(kernel) )[1]; nprotect = 0; PROTECT ( res = Rf_duplicate(x) ); nprotect++; for ( i = 0; i < nz; i++ ) { tgt = &( REAL(res)[i * size.x * size.y] ); src = &( REAL(x)[i * size.x * size.y] ); if ( ! INTEGER(binary)[0] ) { min = max = src[0]; for ( j = 0; j < size.x * size.y; j++ ) { if (src[j] > max) max = src[j]; if (src[j] < min) min = src[j]; } for ( j = 0; j < size.x * size.y; j++ ) { pt = pointFromIndex (j, size.x); tgt[j] = _greymatch(kern, &ksize, src, &size, &pt, INTEGER(what)[0], min , max); } } else { for ( j = 0; j < size.x * size.y; j++ ) { if ( tgt[j] == resetTo ) continue; pt = pointFromIndex (j, size.x); if ( !_match(kern, &ksize, src, &size, &pt, resetTo) ) tgt[j] = resetTo; } } } UNPROTECT (nprotect); return res; }
SEXP interp_(SEXP x, SEXP env, SEXP data) { if (!Rf_isLanguage(x)) return x; if (!Rf_isEnvironment(env)) Rf_error("`env` must be an environment"); return interp_walk(Rf_duplicate(x), env, data); }
static PyObject* Sexp_duplicate(PyObject *self, PyObject *kwargs) { SEXP sexp_self, sexp_copy; PyObject *res; sexp_self = RPY_SEXP((PySexpObject*)self); if (! sexp_self) { PyErr_Format(PyExc_ValueError, "NULL SEXP."); return NULL;; } PROTECT(sexp_copy = Rf_duplicate(sexp_self)); res = (PyObject *) newPySexpObject(sexp_copy, 1); UNPROTECT(1); return res; }
void plot::set_snapshot(const rhost::util::protected_sexp& snapshot) { // Ignore if we already created a snapshot if (_snapshot_varname.empty()) { _snapshot_varname = get_snapshot_varname(); } rhost::util::errors_to_exceptions([&] { SEXP klass = Rf_protect(Rf_mkString("recordedplot")); Rf_classgets(snapshot.get(), klass); SEXP duplicated_snapshot = Rf_protect(Rf_duplicate(snapshot.get())); Rf_defineVar(Rf_install(_snapshot_varname.c_str()), duplicated_snapshot, R_GlobalEnv); Rf_unprotect(2); }); }
/* -------------------------------------------------------------------------- */ SEXP bwlabel(SEXP x) { int i, kx, ky, nz, *dim; int nprotect=0; double index; XYPoint pt; SEXP res; // check image validity validImage(x,0); nz = getNumberOfFrames(x, 0); dim = INTEGER(GET_DIM(x)); XYPoint size(dim[0], dim[1]); if (size.x <= 0 || size.y <= 0) error("image must have positive dimensions"); // initialize result PROTECT(res = Rf_duplicate(x)); nprotect++; // assuming binary images: 0 is background and everything else foreground // foreground is converted here to -1.0 // NO NO NO: I've splitted some labelled objects, I want to relabel the parts, // so I put them to -REAL(res)[i] instead of -1, otherwise they will be merged // as they are connected for (i=0; i<nz*size.x*size.y; i++) { if (REAL(res)[i]!=0.0) REAL(res)[i]=-REAL(res)[i]; } // do the job over images // every pixel equals with R_PosInf is filled with an increasing index, starting from 1 for (i=0; i<nz; i++) { index = 1.0; for (ky=0; ky<size.y ; ky++) { for (kx=0; kx<size.x ; kx++) { if ( REAL(res)[kx + ky*size.x + i*size.x*size.y] < 0 ) { pt.x = kx; pt.y = ky; _floodFill<double>(&(REAL(res)[i*size.x*size.y]), size, pt, index, 0.0); index = index + 1.0; } } } } UNPROTECT (nprotect); return res; }
// Compute Euclidean (L2)/Manhattan (L1) distance map of matrix _a // Input: numeric matrix _a, of size width*height, where 0 is background and everything else is foreground. _a shouldn't contain any NAs // Input: integer _metric. If 0, will compute Euclidean distance and Manhattan distance otherwise // Output: distance matrix of same size as _a SEXP distmap(SEXP _a, SEXP _metric) { SEXP res; int i,nprotect=0,nz; // check validity validImage(_a,0); // initialize width, height, dim width=INTEGER(GET_DIM(_a))[0]; height=INTEGER(GET_DIM(_a))[1]; nz=getNumberOfFrames(_a,0); // initialize vj, where (i,vj[i]) are the coordinates of the closest background pixel to a(i,j) with vj[i]>=j vj=(int *)R_Calloc(height,int); // initialize a a=REAL(_a); // initialize d, the output distance matrix PROTECT(res=Rf_duplicate(_a)); nprotect++; d=REAL(res); for (i=0;i<height*width*nz;i++) d[i]=R_PosInf; // initialize dist, the distance type metric=INTEGER(_metric)[0]; // do the job for (i=0;i<nz;i++) { distmap_onesided(1); distmap_onesided(0); a=a+height*width; d=d+height*width; } // final square root for Euclidean distance d=REAL(res); if (metric==0) for (i=0;i<height*width*nz;i++) d[i]=sqrt(d[i]); // free vj R_Free(vj); UNPROTECT (nprotect); return res; }
CharacterVector reencode_char(SEXP x) { if (Rf_isFactor(x)) return reencode_factor(x); CharacterVector xc(x); R_xlen_t first = get_first_reencode_pos(xc); if (first >= xc.length()) return x; CharacterVector ret(Rf_duplicate(xc)); R_xlen_t len = ret.length(); for (R_xlen_t i = first; i < len; ++i) { SEXP reti = ret[i]; if (reti != NA_STRING && !IS_ASCII(reti) && !IS_UTF8(reti)) { ret[i] = String(Rf_translateCharUTF8(reti), CE_UTF8); } } return ret; }
int SexpEnvironment_setvalue(const SEXP envir, const char* name, const SEXP value) { if (! RINTERF_ISREADY()) { printf("R is not ready.\n"); return -1; } RStatus ^= RINTERF_IDLE; SEXP symbol; symbol = Rf_install(name); //FIXME: is the copy really needed / good ? SEXP value_copy; PROTECT(value_copy = Rf_duplicate(value)); Rf_defineVar(symbol, value_copy, envir); //FIXME: protect/unprotect from garbage collection (for now protect only) UNPROTECT(1); RStatus ^= RINTERF_IDLE; return 0; }
/*----------------------------------------------------------------------- */ SEXP watershed (SEXP x, SEXP _tolerance, SEXP _ext) { SEXP res; int im, i, j, nx, ny, nz, ext, nprotect = 0; double tolerance; nx = INTEGER ( GET_DIM(x) )[0]; ny = INTEGER ( GET_DIM(x) )[1]; nz = getNumberOfFrames(x,0); tolerance = REAL( _tolerance )[0]; ext = INTEGER( _ext )[0]; PROTECT ( res = Rf_duplicate(x) ); nprotect++; int * index = new int[ nx * ny ]; for ( im = 0; im < nz; im++ ) { double * src = &( REAL(x)[ im * nx * ny ] ); double * tgt = &( REAL(res)[ im * nx * ny ] ); /* generate pixel index and negate the image -- filling wells */ for ( i = 0; i < nx * ny; i++ ) { tgt[ i ] = -src[ i ]; index[ i ] = i; } /* from R includes R_ext/Utils.h */ /* will resort tgt as well */ rsort_with_index( tgt, index, nx * ny ); /* reassign tgt as it was reset above but keep new index */ for ( i = 0; i < nx * ny; i++ ) tgt[ i ] = -src[ i ]; SeedList seeds; /* indexes of all seed starting points, i.e. lowest values */ IntList equals; /* queue of all pixels on the same gray level */ IntList nb; /* seed values of assigned neighbours */ int ind, indxy, nbseed, x, y, topseed = 0; IntList::iterator it; TheSeed newseed; PointXY pt; bool isin; /* loop through the sorted index */ for ( i = 0; i < nx * ny && src[ index[i] ] > BG; ) { /* pool a queue of equally lowest values */ ind = index[ i ]; equals.push_back( ind ); for ( i = i + 1; i < nx * ny; ) { if ( src[ index[i] ] != src[ ind ] ) break; equals.push_back( index[i] ); i++; } while ( !equals.empty() ) { /* first check through all the pixels if we can assign them to * existing objects, count checked and reset counter on each assigned * -- exit when counter equals queue length */ for ( j = 0; j < (int) equals.size(); ) { if ((j%1000)==0) R_CheckUserInterrupt(); ind = equals.front(); equals.pop_front(); /* check neighbours: * - if exists one, assign * - if two or more check what should be combined and assign to the steepest * - if none, push back */ /* reset j to 0 every time we assign another pixel to restart the loop */ nb.clear(); pt = pointFromIndex( ind, nx ); /* determine which neighbour we have, push them to nb */ for ( x = pt.x - ext; x <= pt.x + ext; x++ ) for ( y = pt.y - ext; y <= pt.y + ext; y++ ) { if ( x < 0 || y < 0 || x >= nx || y >= ny || (x == pt.x && y == pt.y) ) continue; indxy = x + y * nx; nbseed = (int) tgt[ indxy ]; if ( nbseed < 1 ) continue; isin = false; for ( it = nb.begin(); it != nb.end() && !isin; it++ ) if ( nbseed == *it ) isin = true; if ( !isin ) nb.push_back( nbseed ); } if ( nb.size() == 0 ) { /* push the pixel back and continue with the next one */ equals.push_back( ind ); j++; continue; } tgt[ ind ] = check_multiple(tgt, src, ind, nb, seeds, tolerance, nx, ny ); /* we assigned the pixel, reset j to restart neighbours detection */ j = 0; } /* now we have assigned all that we could */ if ( !equals.empty() ) { /* create a new seed for one pixel only and go back to assigning neighbours */ topseed++; newseed.index = equals.front(); newseed.seed = topseed; equals.pop_front(); tgt[ newseed.index ] = topseed; seeds.push_back( newseed ); } } // assigning equals } // sorted index /* now we need to reassign indexes while some seeds could be removed */ double * finseed = new double[ topseed ]; for ( i = 0; i < topseed; i++ ) finseed[ i ] = 0; i = 0; while ( !seeds.empty() ) { newseed = seeds.front(); seeds.pop_front(); finseed[ newseed.seed - 1 ] = i + 1; i++; } for ( i = 0; i < nx * ny; i++ ) { j = (int) tgt[ i ]; if ( 0 < j && j <= topseed ) tgt[ i ] = finseed[ j - 1 ]; } delete[] finseed; } // loop through images delete[] index; UNPROTECT (nprotect); return res; }
/*----------------------------------------------------------------------- */ SEXP thresh (SEXP x, SEXP param) { int dx, dy, nx, ny, nz, nprotect, * dim, xi, yi, u, v, i; int sx, ex, sy, ey; double offset, * tgt, * src, sum, mean, nFramePix; SEXP res; validImage(x,0); dim = INTEGER ( GET_DIM(x) ); nx = dim[0]; ny = dim[1]; nz = getNumberOfFrames(x,0); dx = (int)( REAL(param)[0] ); dy = (int)( REAL(param)[1] ); offset = REAL(param)[2]; nprotect = 0; nFramePix = (2 * dx + 1) * (2 * dy + 1); PROTECT ( res = Rf_duplicate(x) ); nprotect++; for ( i = 0; i < nz; i++ ) { tgt = &( REAL(res)[ i * nx * ny ] ); src = &( REAL(x)[ i * nx * ny ] ); for ( yi = dy; yi < ny - dy; yi++ ) { sum = 0.0; for ( xi = dx; xi < nx - dx; xi++ ) { if ( xi == dx) { /* first position in a row -- collect new sum */ for ( u = xi - dx; u <= xi + dx; u++ ) for ( v = yi - dy; v <= yi + dy; v++ ) sum += src [u + v * nx]; } else { /* frame moved in the row, modify sum */ for ( v = yi - dy; v <= yi + dy; v++ ) sum += src [xi + dx + v * nx] - src [ xi - dx - 1 + v * nx]; } /* calculate threshold and update tgt data */ mean = sum / nFramePix + offset; sx = xi; ex = xi; sy = yi; ey = yi; if ( xi == dx ) { /* left */ sx = 0; ex = dx; } else if ( xi == nx - dx - 1 ) { /* right */ sx = nx - dx - 1; ex = nx - 1; } if ( yi == dy ) { /* top */ sy = 0; ey = dy; } else if ( yi == ny - dy - 1 ) { /* bottom */ sy = ny - dy - 1; ey = ny - 1; } if ( ex - sx > 0 || ey - sy > 0 ) { for ( u = sx; u <= ex; u++ ) for ( v = sy; v <= ey; v++ ) tgt [u + v * nx] = ( src [u + v * nx] < mean ) ? BG : FG; } else /* thresh current pixel only */ tgt [xi + yi * nx] = ( src [xi + yi * nx] < mean ) ? BG : FG; } } } UNPROTECT (nprotect); return res; }
SEXP RcppList::getList(void) const { SEXP li = PROTECT(Rf_duplicate( listArg )) ; Rf_setAttrib(li, R_NamesSymbol, Rcpp::wrap(names) ); UNPROTECT(1) ; return li; }