USER_OBJECT_
asRRaw(guchar val)
{
USER_OBJECT_ ans;
ans = NEW_RAW(1);
RAW(ans)[0] = val;
return(ans);
}
static PyObject*
EmbeddedR_unserialize(PyObject* self, PyObject* args)
{
PyObject *res;
if (! (rpy_has_status(RPY_R_INITIALIZED))) {
PyErr_Format(PyExc_RuntimeError,
"R cannot evaluate code before being initialized.");
return NULL;
}
char *raw;
Py_ssize_t raw_size;
int rtype;
if (! PyArg_ParseTuple(args, "s#i",
&raw, &raw_size,
&rtype)) {
return NULL;
}
if (rpy_has_status(RPY_R_BUSY)) {
PyErr_Format(PyExc_RuntimeError, "Concurrent access to R is not allowed.");
return NULL;
}
embeddedR_setlock();
/* Not the most memory-efficient; an other option would
* be to create a dummy RAW and rebind "raw" as its content
* (wich seems clearly off the charts).
*/
SEXP raw_sexp, sexp_ser;
PROTECT(raw_sexp = NEW_RAW((int)raw_size));
/*FIXME: use of the memcpy seems to point in the direction of
* using the option mentioned above anyway. */
Py_ssize_t raw_i;
for (raw_i = 0; raw_i < raw_size; raw_i++) {
RAW_POINTER(raw_sexp)[raw_i] = raw[raw_i];
}
PROTECT(sexp_ser = rpy_unserialize(raw_sexp, R_GlobalEnv));
if (TYPEOF(sexp_ser) != rtype) {
UNPROTECT(2);
PyErr_Format(PyExc_ValueError,
"Mismatch between the serialized object"
" and the expected R type"
" (expected %i but got %i)", rtype, TYPEOF(raw_sexp));
return NULL;
}
res = (PyObject*)newPySexpObject(sexp_ser, 1);
UNPROTECT(2);
embeddedR_freelock();
return res;
}
SEXP _new_RAW_from_CharAE(const CharAE *ae)
{
int nelt;
SEXP ans;
if (sizeof(Rbyte) != sizeof(char)) // should never happen!
error("_new_RAW_from_CharAE(): sizeof(Rbyte) != sizeof(char)");
nelt = _CharAE_get_nelt(ae);
PROTECT(ans = NEW_RAW(nelt));
memcpy(RAW(ans), ae->elts, sizeof(char) * nelt);
UNPROTECT(1);
return ans;
}
SEXP amsr_average(SEXP a, SEXP b)
{
PROTECT(a = AS_RAW(a));
PROTECT(b = AS_RAW(b));
int na = LENGTH(a), nb=LENGTH(b);
if (na != nb)
error("lengths must agree but length(a) is %d and length(b) is %d", na, nb);
unsigned char *ap = RAW_POINTER(a);
unsigned char *bp = RAW_POINTER(b);
SEXP res;
PROTECT(res = NEW_RAW(na));
unsigned char *resp = RAW_POINTER(res);
unsigned char A, B;
for (int i = 0; i < na; i++) {
A = ap[i];
B = bp[i];
if (A < 0xfb && B < 0xfb) { // A and B are both OK (the most common case, so put first here)
resp[i] = (unsigned char)(0.5+0.5*(A+B)); // note rounding
} else if (A == 0xff) { // A is land; ignore B and return code for land
resp[i] = 0xff;
} else if (B == 0xff) { // B is land; ignore A and return code for land
resp[i] = 0xff;
} else if (A == 0xfe) { // 254
resp[i] = B; // no A observation, so use B, whatever it is
} else if (B == 0xfe) {
resp[i] = A; // no B observation, so use A, whatever it is
} else if (A == 0xfd) { // 253
resp[i] = B; // bad A observation, so use B, whatever it is
} else if (B == 0xfd) {
resp[i] = A; // bad B observation, so use A, whatever it is
} else if (A == 0xfc) { // 252
resp[i] = B; // A had sea ice; try B (although it is likely also ice)
} else if (B == 0xfc) {
resp[i] = A; // A had sea ice; try A (although it is likely also ice)
} else if (A == 0xfb) { // 251
resp[i] = B; // A was too rainy; try B, on the hope that rain is short-lived
} else if (B == 0xfb) {
resp[i] = A; // B was too rainy; try A, on the hope that rain is short-lived
} else {
resp[i] = 0xff; // Cannot get here
}
}
UNPROTECT(3);
return(res);
}
Datum
plr_get_raw(PG_FUNCTION_ARGS)
{
SEXP result;
SEXP s, t, obj;
int status;
bytea *bvalue = PG_GETARG_BYTEA_P(0);
int len, rsize;
bytea *bresult;
char *brptr;
PROTECT(obj = NEW_RAW(VARSIZE(bvalue)));
memcpy((char *) RAW(obj), VARDATA(bvalue), VARSIZE(bvalue));
/*
* Need to construct a call to
* unserialize(rval)
*/
PROTECT(t = s = allocList(2));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install("unserialize")); t = CDR(t);
SETCAR(t, obj);
PROTECT(result = R_tryEval(s, R_GlobalEnv, &status));
if(status != 0)
{
if (last_R_error_msg)
ereport(ERROR,
(errcode(ERRCODE_DATA_EXCEPTION),
errmsg("R interpreter expression evaluation error"),
errdetail("%s", last_R_error_msg)));
else
ereport(ERROR,
(errcode(ERRCODE_DATA_EXCEPTION),
errmsg("R interpreter expression evaluation error"),
errdetail("R expression evaluation error caught in \"unserialize\".")));
}
len = LENGTH(result);
rsize = VARHDRSZ + len;
bresult = (bytea *) palloc(rsize);
SET_VARSIZE(bresult, rsize);
brptr = VARDATA(bresult);
memcpy(brptr, (char *) RAW(result), rsize - VARHDRSZ);
UNPROTECT(2);
PG_RETURN_BYTEA_P(bresult);
}
// a is an array with e.g. a[,,1] being a matrix of data in the first image
SEXP amsr_composite(SEXP a)
{
//Rprintf("amsr_composite ...\n");
PROTECT(a = AS_RAW(a));
unsigned char *ap = RAW_POINTER(a);
unsigned int n1 = INTEGER(GET_DIM(a))[0];
unsigned int n2 = INTEGER(GET_DIM(a))[1];
unsigned int n3 = INTEGER(GET_DIM(a))[2];
unsigned int n12 = n1 * n2;
//Rprintf("amsr_composite n1=%d n2=%d n3=%d n12=%d\n", n1, n2, n3, n12);
SEXP res;
PROTECT(res = NEW_RAW(n12));
unsigned char *resp = RAW_POINTER(res);
unsigned char A = 'a'; // assignment prevents compiler warning at line 145
for (int i = 0; i < n12; i++) {
double sum = 0.0;
int nsum = 0;
//if (i < 300) Rprintf("i=%d:\n", i);
for (int i3 = 0; i3 < n3; i3++) {
A = ap[i + n12*i3];
if (A < 0xfb) {
sum += A;
nsum++;
//if (i < 300) Rprintf(" i3=%3d A=%3d=0x%02x sum=%5.1f nsum=%d\n", i3, (int)A, A, sum, nsum);
} else {
//if (i < 300) Rprintf(" i3=%3d A=%3d=0x%02x SKIPPED\n", i3, (int)A, A);
}
}
if (nsum)
resp[i] = (unsigned char)floor(0.5 + sum/nsum);
else
resp[i] = A; // will be >= 0xfb ... we inherit the NA type from last image
//if (i < 300) Rprintf(" resp=%d=0x%02x\n", (int)resp[i], resp[i]);
}
SEXP resdim;
PROTECT(resdim = allocVector(INTSXP, 2));
int *resdimp = INTEGER_POINTER(resdim);
resdimp[0] = n1;
resdimp[1] = n2;
SET_DIM(res, resdim);
UNPROTECT(3);
return res;
}
SEXP
R_WriteBitcodeToFile(SEXP r_module, SEXP r_to)
{
llvm::Module *module;
SEXP ans;
module = GET_REF(r_module, Module);
std::string str;
llvm::raw_string_ostream out(str);
llvm::WriteBitcodeToFile(module, out);
std::string tmp = out.str();
size_t len = tmp.size();
PROTECT(ans = NEW_RAW(len));
memcpy(RAW(ans), tmp.data(), len);
UNPROTECT(1);
return(ans);
}
