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;
}
