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