static PyObject*
Sexp___getstate__(PyObject *self)
{
PyObject *res_string;
SEXP sexp = RPY_SEXP((PySexpObject *)self);
if (! sexp) {
PyErr_Format(PyExc_ValueError, "NULL SEXP.");
return NULL;
}
SEXP sexp_ser;
PROTECT(sexp_ser = rpy_serialize(sexp, R_GlobalEnv));
if (TYPEOF(sexp_ser) != RAWSXP) {
UNPROTECT(1);
PyErr_Format(PyExc_RuntimeError,
"R's serialize did not return a raw vector.");
return NULL;
}
/* PyByteArray is only available with Python >= 2.6 */
/* res = PyByteArray_FromStringAndSize(sexp_ser, len); */
/*FIXME: is this working on 64bit archs ? */
#if (PY_VERSION_HEX < 0x03010000)
res_string = PyString_FromStringAndSize((void *)RAW_POINTER(sexp_ser),
(Py_ssize_t)LENGTH(sexp_ser));
#else
res_string = PyBytes_FromStringAndSize((void *)RAW_POINTER(sexp_ser),
(Py_ssize_t)LENGTH(sexp_ser));
#endif
UNPROTECT(1);
return res_string;
}
SEXP match3bytes(SEXP buf, SEXP m1, SEXP m2, SEXP m3)
{
int i, j, n, n_match;
double *resp;
unsigned char *bufp, *m1p, *m2p, *m3p;
SEXP res;
PROTECT(buf = AS_RAW(buf));
PROTECT(m1 = AS_RAW(m1));
PROTECT(m2 = AS_RAW(m2));
PROTECT(m3 = AS_RAW(m3));
bufp = RAW_POINTER(buf);
m1p = RAW_POINTER(m1);
m2p = RAW_POINTER(m2);
m3p = RAW_POINTER(m3);
n = LENGTH(buf);
n_match = 0;
for (i = 0; i < n - 2; i++) {
if (bufp[i] == *m1p && bufp[i + 1] == *m2p && bufp[i + 2] == *m3p) {
n_match++;
++i; /* skip */
++i; /* skip */
}
}
PROTECT(res = NEW_NUMERIC(n_match));
resp = NUMERIC_POINTER(res);
j = 0;
for (i = 0; i < n - 2; i++) {
if (j <= n_match && bufp[i] == *m1p && bufp[i + 1] == *m2p && bufp[i + 2] == *m3p) {
resp[j++] = i + 1; /* the 1 is to offset from C to R */
}
}
UNPROTECT(5);
return(res);
}
/*#define DEBUG*/
SEXP nortek_checksum(SEXP buf, SEXP key)
{
/* http://www.nortek-as.com/en/knowledge-center/forum/current-profilers-and-current-meters/367698326 */
/*
R CMD SHLIB bitwise.c
library(oce)
f <- "/Users/kelley/data/archive/sleiwex/2008/moorings/m06/vector1943/194301.vec" ## dir will change; times are odd
buf <- readBin(f, what="raw", n=1e4)
vvd.start <- matchBytes(buf, 0xa5, 0x10)
ok <- NULL;dyn.load("~/src/R-kelley/oce/src/bitwise.so");for(i in 1:200) {ok <- c(ok, .Call("nortek_checksum",buf[vvd.start[i]+0:23], c(0xb5, 0x8c)))}
*/
int i, n;
short check_value;
int *resp;
unsigned char *bufp, *keyp;
SEXP res;
PROTECT(key = AS_RAW(key));
PROTECT(buf = AS_RAW(buf));
bufp = (unsigned char*)RAW_POINTER(buf);
keyp = (unsigned char*)RAW_POINTER(key);
#ifdef DEBUG
Rprintf("buf[0]=0x%02x\n",bufp[0]);
Rprintf("buf[1]=0x%02x\n",bufp[1]);
Rprintf("buf[2]=0x%02x\n",bufp[2]);
Rprintf("key[0]=0x%02x\n", keyp[0]);
Rprintf("key[1]=0x%02x\n", keyp[1]);
#endif
n = LENGTH(buf);
check_value = (((short)keyp[0]) << 8) | (short)keyp[1];
#ifdef DEBUG
Rprintf("check_value= %d\n", check_value);
Rprintf("n=%d\n", n);
#endif
short *sbufp = (short*) bufp;
for (i = 0; i < (n - 2)/2; i++) {
#ifdef DEBUG
Rprintf("i=%d buf=0x%02x\n", i, sbufp[i]);
#endif
check_value += sbufp[i];
#ifdef DEBUG
Rprintf("after, check_value=%d\n", check_value);
#endif
}
short checksum;
checksum = (((short)bufp[n-1]) << 8) | (short)bufp[n-2];
#ifdef DEBUG
Rprintf("CHECK AGAINST 0x%02x 0x%02x\n", bufp[n-2], bufp[n-1]);
Rprintf("CHECK AGAINST %d\n", checksum);
#endif
PROTECT(res = NEW_LOGICAL(1));
resp = LOGICAL_POINTER(res);
*resp = check_value == checksum;
UNPROTECT(3);
return(res);
}
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);
}
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;
}
// 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 ldc_sontek_adv_22(SEXP buf, SEXP max)
{
/* ldc = locate data chunk; _sontek_adv = for a SonTek ADV (with temperature and/or pressure installed; see p95 of sontek-adv-op-man-2001.pdf)
* BYTE Contents
* 1 0x85 [call this key1 in code]
* 2 0x16 (length of record, 0x16 is 22 base 10) [ call this key2 in code]
* 3:4 SampleNum, a little-endian unsigned integer. This should increase by 1 from sample
* to sample, and it wraps at value 65535
* 5:6 x velocity component, signed 2-byte integer, in 0.1 mm/s [QUESTION: is there a scale factor issue?]
* 7:8 y "
* 9:10 z "
* 11 beam 1 amplitude
* 12 beam 2 "
* 13 beam 3 "
* 14 beam 1 correlation
* 15 beam 2 "
* 16 beam 3 "
* 17:18 temperature (in 0.01 degC), signed little-endian integer
* 19:20 pressure (in counts), signed little-endian integer
* 21:22 checksum of bytes 1 to 20
*/
/*
# testing
R CMD SHLIB bitwise.o ; R --no-save < a.R
# with a.R as follows:
f <- file('~/m05_sontek_adv','rb')
seek(f,0,"end")
n <- seek(f,0,"start")
buf <- readBin(f, "raw", n)
dyn.load("bitwise.so")
p <- .Call("ldc_sontek_adv_22", buf, 10)
np <- length(p)
pp <- sort(c(p, p+1)) # for two-byte reading
sample.number <- readBin(buf[pp+2], "integer", signed=FALSE, size=2, endian="little",n=np)
u1 <- 1e-4 * readBin(buf[pp+4], "integer", signed=TRUE, size=2, endian="little",n=np)
u2 <- 1e-4 * readBin(buf[pp+6], "integer", signed=TRUE, size=2, endian="little",n=np)
u3 <- 1e-4 * readBin(buf[pp+8], "integer", signed=TRUE, size=2, endian="little",n=np)
a1 <- readBin(buf[p+10], "integer", signed=TRUE, size=1, n=np)
a2 <- readBin(buf[p+11], "integer", signed=TRUE, size=1, n=np)
a3 <- readBin(buf[p+12], "integer", signed=TRUE, size=1, n=np)
c1 <- readBin(buf[p+13], "integer", signed=TRUE, size=1, n=np)
c2 <- readBin(buf[p+14], "integer", signed=TRUE, size=1, n=np)
c3 <- readBin(buf[p+15], "integer", signed=TRUE, size=1, n=np)
temperature <- 0.01 * readBin(buf[sort(c(p, p+1))+16], "integer", signed=TRUE, size=2, endian="little",n=np)
pressure <- readBin(buf[sort(c(p, p+1))+18], "integer", signed=TRUE, size=2, endian="little",n=np)
*/
unsigned char *pbuf;
PROTECT(buf = AS_RAW(buf));
PROTECT(max = AS_INTEGER(max));
/* FIXME: check lengths of match and key */
pbuf = RAW_POINTER(buf);
int max_lres = *INTEGER_POINTER(max);
int lres;
int lbuf = LENGTH(buf);
SEXP res;
#ifdef DEBUG
Rprintf("lbuf=%d, max=%d\n",lbuf,max_lres);
#endif
/* Count matches, so we can allocate the right length */
unsigned char byte1 = 0x85;
unsigned char byte2 = 0x16; /* this equal 22 base 10, i.e. the number of bytes in record */
unsigned int matches = 0;
unsigned short int check_sum_start = ((unsigned short)0xa5<<8) | ((unsigned short)0x96); /* manual p96 says 0xA596; assume little-endian */
unsigned short int check_sum, desired_check_sum;
if (max_lres < 0)
max_lres = 0;
for (int i = 0; i < lbuf - byte2; i++) { /* note that we don't look to the very end */
check_sum = check_sum_start;
if (pbuf[i] == byte1 && pbuf[i+1] == byte2) { /* match first 2 bytes, now check the checksum */
#ifdef DEBUG
Rprintf("tentative match %d at i = %d ... ", matches, i);
#endif
for (int c = 0; c < 20; c++)
check_sum += (unsigned short int)pbuf[i + c];
desired_check_sum = ((unsigned short)pbuf[i+20]) | ((unsigned short)pbuf[i+21] << 8);
if (check_sum == desired_check_sum) {
matches++;
#ifdef DEBUG
Rprintf("good match (check_sum=%d)\n", check_sum);
#endif
if (max_lres != 0 && matches >= max_lres)
break;
} else {
#ifdef DEBUG
Rprintf("bad checksum\n");
#endif
}
}
}
/* allocate space, then run through whole buffer again, noting the matches */
lres = matches;
if (lres > 0) {
PROTECT(res = NEW_INTEGER(lres));
int *pres = INTEGER_POINTER(res);
#ifdef DEBUG
Rprintf("getting space for %d matches\n", lres);
#endif
unsigned int ires = 0;
for (int i = 0; i < lbuf - byte2; i++) { /* note that we don't look to the very end */
check_sum = check_sum_start;
if (pbuf[i] == byte1 && pbuf[i+1] == byte2) { /* match first 2 bytes, now check the checksum */
for (int c = 0; c < 20; c++)
check_sum += (unsigned short int)pbuf[i + c];
desired_check_sum = ((unsigned short)pbuf[i+20]) | ((unsigned short)pbuf[i+21] << 8);
if (check_sum == desired_check_sum) {
pres[ires++] = i + 1; /* the +1 is to get R pointers */
}
if (ires > lres) /* FIXME: or +1? */
break;
}
}
UNPROTECT(3);
return(res);
} else {
PROTECT(res = NEW_INTEGER(1));
int *pres = INTEGER_POINTER(res);
pres[0] = 0;
UNPROTECT(3);
return(res);
}
}
/*#define DEBUG 1*/
SEXP locate_byte_sequences(SEXP buf, SEXP match, SEXP len, SEXP key, SEXP max)
{
/*
* locate_byte_sequences() = function to be used for e.g. nortek adp / adv files
* buf = buffer to be scanned
* match = set of bytes that mark start of sequences
* len = length of sequence
* key = key added to checksum, and to be checked against last 2 bytes of sequence
* max = 0 to use whole buffer, positive integer to limit to that many matches
*/
/*
R CMD SHLIB bitwise.c
*/
/*
library(oce)
f <- "/Users/kelley/data/archive/sleiwex/2008/moorings/m06/adv/nortek_1943/raw/adv_nortek_1943.vec"
buf <- readBin(f, what="raw", n=1e6)
vvd.start <- matchBytes(buf, 0xa5, 0x10)
dyn.load("~/src/R-kelley/oce/src/bitwise.so")
s <- .Call("locate_byte_sequences",buf, c(0xa5, 0x10), 24, c(0xb5, 0x8c), 0)
print(s)
print(vvd.start)
*/
unsigned char *pbuf, *pmatch, *pkey;
PROTECT(buf = AS_RAW(buf));
PROTECT(match = AS_RAW(match));
PROTECT(len = AS_INTEGER(len));
PROTECT(key = AS_RAW(key));
PROTECT(max = AS_INTEGER(max));
/* FIXME: check lengths of match and key */
pbuf = RAW_POINTER(buf);
pmatch = RAW_POINTER(match);
pkey = RAW_POINTER(key);
int lsequence = *INTEGER_POINTER(len);
int max_lres = *INTEGER_POINTER(max);
#ifdef DEBUG
Rprintf("lsequence=%d\n",lsequence);
#endif
int lmatch = LENGTH(match);
int lbuf = LENGTH(buf);
int lkey = LENGTH(key);
if (lkey != 2) error("key length must be 2");
int ires = 0, lres = (int)(lbuf / lsequence + 3); /* get some extra space; fill some with NA */
SEXP res;
#ifdef DEBUG
Rprintf("lsequence=%d, lres=%d\n",lsequence,lres);
#endif
/* Rprintf("max_lres=%d\n", max_lres); */
if (max_lres > 0)
lres = max_lres;
PROTECT(res = NEW_INTEGER(lres));
int *pres = INTEGER_POINTER(res);
/* Count matches, so we can allocate the right length */
short lsequence2 = lsequence / 2;
for (int i = 0; i < lbuf - lsequence; i++) {
short check_value = (((short)pkey[0]) << 8) | (short)pkey[1];
int found = 0;
for (int m = 0; m < lmatch; m++) {
if (pbuf[i+m] == pmatch[m])
found++;
else
break;
}
if (found == lmatch) {
/* FIXME: should bit-twiddle this to work on all endian types */
short *check = (short*)(pbuf+i);
/*Rprintf(" %d", check_value);*/
for (int cc = 0; cc < lsequence2 - 1; cc++) { /* last 2-byte chunk is the test value */
check_value += *check++;
/*Rprintf(" %d", check_value);*/
}
short check_sum = (((short)pbuf[i+lsequence-1]) << 8) | (short)pbuf[i+lsequence-2];
#ifdef DEBUG
Rprintf("i=%d lbuf=%d ires=%d lres=%d check_value=%d vs check_sum %d match=%d\n", i, lbuf, ires, lres, check_value, check_sum, check_value==check_sum);
#endif
if (check_value == check_sum) {
pres[ires++] = i + 1;
i += lsequence - lmatch; /* no need to check within sequence */
}
if (ires >= lres)
break;
}
i += lmatch - 1; /* skip over matched bytes */
if (i > (lbuf - lsequence))
break; /* FIXME: can this ever happen? */
}
SET_LENGTH(res, ires);
UNPROTECT(6);
return(res);
}
/*#define DEBUG 1*/
SEXP locate_vector_imu_sequences(SEXP buf)
{
/*
* imu = Inertial Motion Unit (system-integrator-manual_Dec2014_jan.pdf p30-32)
*
* *(buf) 0xa5
* *(buf+1) 0x71
* *(buf+2,3) int, # bytes in structure
* There are 3 possibilities, keyed by *(buf+6), "K", say
*
* Case | K | Contents
* =====|======|=====================================================================
* A | 0xc2 | ?
* B | 0xcc | Acceleration, Angular Rate, Magnetometer Vectors, Orientation Matrix
* C | 0xd2 | Gyro-stabilized Acceleration, Angular Rate, Magnetometer Vectors
* D | 0xd3 | DeltaAngle, DeltaVelocity, Magnetometer Vectors
*
* QUESTION: what is AHRSchecksum? do we check that? And what is
* this second 'Checksum'?
* Case A has checksum starting at offset 84 (sum of all words in structure)
*/
/*
library(oce)
system("R CMD SHLIB bitwise.c")
dyn.load("bitwise.so")
f <- "/Users/kelley/src/dolfyn/example_data/vector_data_imu01.VEC"
buf <- readBin(f, what="raw", n=1e5)
a <- .Call("locate_vector_imu_sequences", buf)
for (aa in a[1:10]) {
message(paste(paste("0x", buf[aa+seq.int(0, 6L)], sep=""), collapse=" "))
}
ensembleCounter <- as.numeric(buf[a + 4])
plot(seq_along(a), ensembleCounter, type='l')
*/
PROTECT(buf = AS_RAW(buf));
unsigned char *bufp;
bufp = RAW_POINTER(buf);
int bufn = LENGTH(buf);
SEXP res;
PROTECT(res = NEW_INTEGER(bufn)); // definitely more than enough space
int *resp = INTEGER_POINTER(res);
int resn = 0;
//int check=10; // check this many instance of 0xa5,0x71
// We check 5 bytes, on the assumption that false positives will be
// effectively zero then (1e-12, if independent random numbers
// in range 0 to 255).
// FIXME: test the checksum, but SIG2 does not state how.
for (int i = 0; i < bufn-1; i++) {
if (bufp[i] == 0xa5 && bufp[i+1] == 0x71) {
//if (check-- > 0) Rprintf("IMU test: buf[%d]=0x%02x, buf[%d+2]=0x%02x, buf[%d+5]=0x%02x\n", i, bufp[i], i, bufp[i+2], i, bufp[i+5]);
// Check at offset=5, which must be 1 of 3 choices.
if (bufp[i+5] == 0xc3) {
// FIXME: should verify this length check, which I got by inspecting dolfyn code
// and a file provided privately in March 2016.
if (bufp[i+2] == 0x24 && bufp[i+3] == 0x00) {
resp[resn++] = i + 1; // add 1 for R notation
i++; //FIXME: skip to end, when we really trust identification
}
} else if (bufp[i+5] == 0xcc) {
// length indication should be 0x2b=43=86/2 (SIG2, top of page 31)
if (bufp[i+2] == 0x2b && bufp[i+3] == 0x00) {
resp[resn++] = i + 1; // add 1 for R notation
i++; //FIXME: skip to end, when we really trust identification
}
} else if (bufp[i+5] == 0xd2) { // decimal 210
// length indication should be 0x19=25=50/2 (SIG2, middle of page 31)
if (bufp[i+2] == 0x19 && bufp[i+3] == 0x00) {
resp[resn++] = i + 1; // add 1 for R notation
i++; //FIXME: skip to end, when we really trust identification
}
} else if (bufp[i+5] ==0xd3) { // decimal 211
// length indication should be 0x19=25=50/2 (SIG2, page 32)
if (bufp[i+2] == 0x19 && bufp[i+3] == 0x00) {
resp[resn++] = i + 1; // add 1 for R notation
i++; //FIXME: skip to end, when we really trust identification
}
}
}
}
SET_LENGTH(res, resn);
UNPROTECT(2);
return(res);
}
SEXP match2bytes(SEXP buf, SEXP m1, SEXP m2, SEXP demand_sequential)
{
int i, j, n, n_match, ds;
double *resp;
unsigned char *bufp, *m1p, *m2p;
SEXP res;
PROTECT(buf = AS_RAW(buf));
PROTECT(m1 = AS_RAW(m1));
PROTECT(m2 = AS_RAW(m2));
PROTECT(demand_sequential = AS_INTEGER(demand_sequential));
bufp = RAW_POINTER(buf);
m1p = RAW_POINTER(m1);
m2p = RAW_POINTER(m2);
ds = *INTEGER(demand_sequential);
n = LENGTH(buf);
unsigned short seq_last=0, seq_this;
// Rprintf("demand_sequential=%d\n",ds);
int nnn=10;
/* FIXME: the two passes repeat too much code, and should be done as a subroutine */
//
// Pass 1: allocate vector
//
n_match = 0; /* don't demand anything at start */
for (i = 0; i < n - 1; i++) {
if (bufp[i] == *m1p && bufp[i + 1] == *m2p) {
if (ds) {
seq_this = (((unsigned short)bufp[i + 3]) << 8) | (unsigned short)bufp[i + 2];
// if (nnn > 0) Rprintf("i=%d seq_this=%d seq_last=%d ... ",i,seq_this,seq_last);
if (!n_match || (seq_this == (seq_last + 1)) || (seq_this == 1 && seq_last == 65535)) { /* is second needed, given short type? */
n_match++;
++i; // skip
seq_last = seq_this;
// if (nnn > 0) Rprintf("KEEP\n");
} else {
// if (nnn > 0) Rprintf("DISCARD\n");
}
//nnn--;
} else {
n_match++;
++i; // skip
}
}
}
//
// Pass 2: fill in the vector
//
PROTECT(res = NEW_NUMERIC(n_match));
resp = NUMERIC_POINTER(res);
j = 0;
seq_last = 0;
nnn = 1000;
//Rprintf("PASS 2\n");
n_match = 0; /* don't demand anything at start */
for (i = 0; i < n - 1; i++) {
// Rprintf("[%d]:", i);
if (bufp[i] == *m1p && bufp[i + 1] == *m2p) {
if (ds) {
seq_this = (((unsigned short)bufp[i + 3]) << 8) | (unsigned short)bufp[i + 2];
//if (nnn > 0) Rprintf("i=%d seq_this=%d seq_last=%d ... ",i,seq_this,seq_last);
if (!n_match || (seq_this == (seq_last + 1)) || (seq_this == 1 && seq_last == 65535)) { /* is second needed, given short type? */
n_match++;
resp[j++] = i + 1; /* the 1 is to offset from C to R */
++i; /* skip */
seq_last = seq_this;
//if (nnn > 0) Rprintf("KEEP\n");
} else {
//if (nnn > 0) Rprintf("DISCARD\n");
}
nnn--;
} else {
resp[j++] = i + 1; /* the 1 is to offset from C to R */
++i; /* skip */
}
}
}
UNPROTECT(5);
return(res);
}
SEXP landsat_numeric_to_bytes(SEXP m, SEXP bits)
{
int nrow = INTEGER(GET_DIM(m))[0];
int ncol = INTEGER(GET_DIM(m))[1];
#ifdef DEBUG
Rprintf("landsat_numeric_to_bytes() given matrix with nrow %d and ncol %d\n",
nrow, ncol);
#endif
PROTECT(bits = AS_INTEGER(bits));
int *bitsp = INTEGER_POINTER(bits);
int two_byte = (*bitsp) > 8;
#ifdef DEBUG
Rprintf("landsat_numeric_to_bytes has bits=%d\n", *bitsp);
#endif
SEXP lres;
SEXP lres_names;
SEXP lsb; // least-significant byte matrix
PROTECT(lsb = allocMatrix(RAWSXP, nrow, ncol));
unsigned char* lsbp = RAW_POINTER(lsb);
SEXP msb; // most-significant byte matrix
if (two_byte)
PROTECT(msb = allocMatrix(RAWSXP, nrow, ncol));
else
PROTECT(msb = allocVector(RAWSXP, 1));
unsigned char* msbp = RAW_POINTER(msb);
if (!two_byte)
*msbp = 0;
PROTECT(lres = allocVector(VECSXP, 2));
PROTECT(lres_names = allocVector(STRSXP, 2));
// Check endianness
unsigned int x = 1;
char *c = (char*) &x;
int little_endian = (int)*c;
#ifdef DEBUG
Rprintf("little_endian: %d\n", little_endian);
#endif
// fill up arrays
double *mp = REAL(m);
// No need to index by i and j here; this will speed up
int n = nrow * ncol;
if (two_byte) {
if (little_endian) {
for (int i = 0; i < n; i++) {
double mij = mp[i];
unsigned int mij_int = (unsigned int)(65535*mij);
unsigned char ms = (mij_int & 0xFF00) >> 8;
unsigned char ls = mij_int & 0x00FF;
#ifdef DEBUG
Rprintf("i %d, m: %f -> %d -> msb 0x%02x lsb 0x%02x (little endian two-byte)\n", i, mij, mij_int, ms, ls);
#endif
lsbp[i] = ls;
msbp[i] = ms;
}
} else {
// big endian below
for (int i = 0; i < n; i++) {
double mij = mp[i];
unsigned int mij_int = (unsigned int)(65535*mij);
unsigned char ls = (mij_int & 0xFF00) >> 8;
unsigned char ms = mij_int & 0x00FF;
#ifdef DEBUG
Rprintf("i %d, m: %f -> %d -> msb 0x%02x lsb 0x%02x (big endian two-byte)\n", i, mij, mij_int, ms, ls);
#endif
lsbp[i] = ls;
msbp[i] = ms;
}
}
} else {
SEXP ldc_rdi(SEXP buf, SEXP max)
{
/* ldc_rdi = locate data chunk for RDI
* Ref: WorkHorse Commands and Output Data Format_Nov07.pdf
* p124: header structure (note that 'number of bytes in ensemble'
* does *not* count the first 2 bytes; it's really an offset to the
* checksum)
* p158 (section 5.8) checksum
*/
PROTECT(buf = AS_RAW(buf));
PROTECT(max = AS_INTEGER(max));
/* FIXME: check lengths of match and key */
unsigned char *pbuf = RAW_POINTER(buf);
int max_lres = *INTEGER_POINTER(max);
if (max_lres < 0)
error("'max' must be positive");
int lres;
int lbuf = LENGTH(buf);
SEXP res;
#ifdef DEBUG
Rprintf("lbuf=%d, max=%d\n",lbuf,max_lres);
#endif
/* Count matches, so we can allocate the right length */
unsigned char byte1 = 0x7f;
unsigned char byte2 = 0x7f; /* this equal 22 base 10, i.e. the number of bytes in record */
unsigned int matches = 0;
unsigned short int check_sum, desired_check_sum;
unsigned int bytes_to_check = 0;
#ifdef DEBUG
Rprintf("max_lres %d\n", max_lres);
#endif
for (int i = 0; i < lbuf - 1; i++) { /* note that we don't look to the very end */
if (pbuf[i] == byte1 && pbuf[i+1] == byte2) { /* match first 2 bytes, now check the checksum */
if (matches == 0)
bytes_to_check = pbuf[i+2] + 256 * pbuf[i+3];
check_sum = 0;
for (int c = 0; c < bytes_to_check; c++)
check_sum += (unsigned short int)pbuf[i + c];
desired_check_sum = ((unsigned short)pbuf[i+bytes_to_check+0]) | ((unsigned short)pbuf[i+bytes_to_check+1] << 8);
if (check_sum == desired_check_sum) {
matches++;
#ifdef DEBUG
Rprintf("buf[%d] ok\n", i);
#endif
if (max_lres != 0 && matches >= max_lres)
break;
} else {
#ifdef DEBUG
Rprintf("buf[%d] checksum %d (needed %d)\n", i, check_sum, desired_check_sum);
#endif
}
}
}
R_CheckUserInterrupt();
/* allocate space, then run through whole buffer again, noting the matches */
lres = matches;
if (lres > 0) {
PROTECT(res = NEW_INTEGER(lres));
int *pres = INTEGER_POINTER(res);
#ifdef DEBUG
Rprintf("getting space for %d matches\n", lres);
#endif
unsigned int ires = 0;
for (int i = 0; i < lbuf - 1; i++) { /* note that we don't look to the very end */
check_sum = 0;
if (pbuf[i] == byte1 && pbuf[i+1] == byte2) { /* match first 2 bytes, now check the checksum */
for (int c = 0; c < bytes_to_check; c++)
check_sum += (unsigned short int)pbuf[i + c];
desired_check_sum = ((unsigned short)pbuf[i+bytes_to_check]) | ((unsigned short)pbuf[i+bytes_to_check+1] << 8);
if (check_sum == desired_check_sum)
pres[ires++] = i + 1; /* the +1 is to get R pointers */
if (ires >= lres)
break;
}
}
} else {
PROTECT(res = NEW_INTEGER(1));
int *pres = INTEGER_POINTER(res);
pres[0] = 0;
}
UNPROTECT(3);
return(res);
}