SEXP attribute_hidden complex_math2(SEXP call, SEXP op, SEXP args, SEXP env)
{
R_xlen_t i, n, na, nb;
Rcomplex ai, bi, *a, *b, *y;
SEXP sa, sb, sy;
Rboolean naflag = FALSE;
cm2_fun f;
switch (PRIMVAL(op)) {
case 0: /* atan2 */
f = z_atan2; break;
case 10001: /* round */
f = z_rround; break;
case 2: /* passed from do_log1arg */
case 10:
case 10003: /* passed from do_log */
f = z_logbase; break;
case 10004: /* signif */
f = z_prec; break;
default:
errorcall_return(call, _("unimplemented complex function"));
}
PROTECT(sa = coerceVector(CAR(args), CPLXSXP));
PROTECT(sb = coerceVector(CADR(args), CPLXSXP));
na = XLENGTH(sa); nb = XLENGTH(sb);
if ((na == 0) || (nb == 0)) {
UNPROTECT(2);
return(allocVector(CPLXSXP, 0));
}
n = (na < nb) ? nb : na;
PROTECT(sy = allocVector(CPLXSXP, n));
a = COMPLEX(sa); b = COMPLEX(sb); y = COMPLEX(sy);
for (i = 0; i < n; i++) {
ai = a[i % na]; bi = b[i % nb];
if(ISNA(ai.r) && ISNA(ai.i) &&
ISNA(bi.r) && ISNA(bi.i)) {
y[i].r = NA_REAL; y[i].i = NA_REAL;
} else {
f(&y[i], &ai, &bi);
if ( (ISNAN(y[i].r) || ISNAN(y[i].i)) &&
!(ISNAN(ai.r) || ISNAN(ai.i) || ISNAN(bi.r) || ISNAN(bi.i)) )
naflag = TRUE;
}
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
if(n == na) {
DUPLICATE_ATTRIB(sy, sa);
} else if(n == nb) {
DUPLICATE_ATTRIB(sy, sb);
}
UNPROTECT(3);
return sy;
}
SEXP attribute_hidden do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, el;
R_xlen_t i, len;
int start, stop, k, l;
size_t slen;
cetype_t ienc;
const char *ss;
char *buf;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("extracting substrings from a non-character object"));
len = XLENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
for (i = 0; i < len; i++) {
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
el = STRING_ELT(x,i);
if (el == NA_STRING || start == NA_INTEGER || stop == NA_INTEGER) {
SET_STRING_ELT(s, i, NA_STRING);
continue;
}
ienc = getCharCE(el);
ss = CHAR(el);
slen = strlen(ss); /* FIXME -- should handle embedded nuls */
buf = R_AllocStringBuffer(slen+1, &cbuff);
if (start < 1) start = 1;
if (start > stop || start > slen) {
buf[0] = '\0';
} else {
if (stop > slen) stop = (int) slen;
substr(buf, ss, ienc, start, stop);
}
SET_STRING_ELT(s, i, mkCharCE(buf, ienc));
}
R_FreeStringBufferL(&cbuff);
}
DUPLICATE_ATTRIB(s, x);
/* This copied the class, if any */
UNPROTECT(1);
return s;
}
// 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 d, the output distance matrix
PROTECT(res = allocVector(REALSXP, XLENGTH(_a)) );
nprotect++;
DUPLICATE_ATTRIB(res, _a);
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
int sizexy = height*width;
int offset = 0;
for (i=0; i<nz; i++, offset+=sizexy) {
d = &(REAL(res)[offset]);
switch (TYPEOF(_a)) {
case LGLSXP:
case INTSXP:
_distmap<int>( &(INTEGER(_a)[offset]) );
break;
case REALSXP:
_distmap<double>( &(REAL(_a)[offset]) );
break;
}
}
// 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]);
R_Free(vj);
UNPROTECT (nprotect);
return res;
}
SEXP reassign_function(SEXP name, SEXP env, SEXP old_fun, SEXP new_fun)
{
if (TYPEOF(name) != SYMSXP) error("name must be a symbol");
if (TYPEOF(env) != ENVSXP) error("env must be an environment");
if (TYPEOF(old_fun) != CLOSXP) error("old_fun must be a function");
if (TYPEOF(new_fun) != CLOSXP) error("new_fun must be a function");
SET_FORMALS(old_fun, FORMALS(new_fun));
SET_BODY(old_fun, BODY(new_fun));
SET_CLOENV(old_fun, CLOENV(new_fun));
DUPLICATE_ATTRIB(old_fun, new_fun);
return R_NilValue;
}
static SEXP shallow(SEXP dt, SEXP cols, R_len_t n)
{
// NEW: cols argument to specify the columns to shallow copy on. If NULL, all columns.
// called from alloccol where n is checked carefully, or from shallow() at R level
// where n is set to truelength (i.e. a shallow copy only with no size change)
SEXP newdt, names, newnames;
R_len_t i,l;
int protecti=0;
PROTECT(newdt = allocVector(VECSXP, n)); // to do, use growVector here?
protecti++;
//copyMostAttrib(dt, newdt); // including class
DUPLICATE_ATTRIB(newdt, dt);
// TO DO: keepattr() would be faster, but can't because shallow isn't merely a shallow copy. It
// also increases truelength. Perhaps make that distinction, then, and split out, but marked
// so that the next change knows to duplicate.
// Does copyMostAttrib duplicate each attrib or does it point? It seems to point, hence DUPLICATE_ATTRIB
// for now otherwise example(merge.data.table) fails (since attr(d4,"sorted") gets written by setnames).
names = getAttrib(dt, R_NamesSymbol);
PROTECT(newnames = allocVector(STRSXP, n));
protecti++;
if (isNull(cols)) {
l = LENGTH(dt);
for (i=0; i<l; i++) SET_VECTOR_ELT(newdt, i, VECTOR_ELT(dt,i));
if (length(names)) {
if (length(names) < l) error("Internal error: length(names)>0 but <length(dt)");
for (i=0; i<l; i++) SET_STRING_ELT(newnames, i, STRING_ELT(names,i));
}
// else an unnamed data.table is valid e.g. unname(DT) done by ggplot2, and .SD may have its names cleared in dogroups, but shallow will always create names for data.table(NULL) which has 100 slots all empty so you can add to an empty data.table by reference ok.
} else {
l = length(cols);
for (i=0; i<l; i++) SET_VECTOR_ELT(newdt, i, VECTOR_ELT(dt,INTEGER(cols)[i]-1));
if (length(names)) {
// no need to check length(names) < l here. R-level checks if all value
// in 'cols' are valid - in the range of 1:length(names(x))
for (i=0; i<l; i++) SET_STRING_ELT( newnames, i, STRING_ELT(names,INTEGER(cols)[i]-1) );
}
}
setAttrib(newdt, R_NamesSymbol, newnames);
// setAttrib appears to change length and truelength, so need to do that first _then_ SET next,
// otherwise (if the SET were were first) the 100 tl is assigned to length.
SETLENGTH(newnames,l);
SET_TRUELENGTH(newnames,n);
SETLENGTH(newdt,l);
SET_TRUELENGTH(newdt,n);
setselfref(newdt);
// SET_NAMED(dt,1); // for some reason, R seems to set NAMED=2 via setAttrib? Need NAMED to be 1 for passing to assign via a .C dance before .Call (which sets NAMED to 2), and we can't use .C with DUP=FALSE on lists.
UNPROTECT(protecti);
return(newdt);
}
static R_INLINE SEXP duplicate_list(SEXP s, Rboolean deep)
{
SEXP sp, vp, val;
PROTECT(s);
val = R_NilValue;
for (sp = s; sp != R_NilValue; sp = CDR(sp))
val = CONS(R_NilValue, val);
PROTECT(val);
for (sp = s, vp = val; sp != R_NilValue; sp = CDR(sp), vp = CDR(vp)) {
SETCAR(vp, duplicate_child(CAR(sp), deep));
COPY_TAG(vp, sp);
DUPLICATE_ATTRIB(vp, sp, deep);
}
UNPROTECT(2);
return val;
}
SEXP attribute_hidden do_abbrev(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
R_xlen_t i, len;
int minlen;
Rboolean warn = FALSE;
const char *s;
const void *vmax;
checkArity(op,args);
x = CAR(args);
if (!isString(x))
error(_("the first argument must be a character vector"));
len = XLENGTH(x);
PROTECT(ans = allocVector(STRSXP, len));
minlen = asInteger(CADR(args));
vmax = vmaxget();
for (i = 0 ; i < len ; i++) {
if (STRING_ELT(x, i) == NA_STRING)
SET_STRING_ELT(ans, i, NA_STRING);
else {
s = translateChar(STRING_ELT(x, i));
if(strlen(s) > minlen) {
warn = warn | !strIsASCII(s);
R_AllocStringBuffer(strlen(s), &cbuff);
SET_STRING_ELT(ans, i, stripchars(s, minlen));
} else SET_STRING_ELT(ans, i, mkChar(s));
}
vmaxset(vmax);
}
if (warn) warning(_("abbreviate used with non-ASCII chars"));
DUPLICATE_ATTRIB(ans, x);
/* This copied the class, if any */
R_FreeStringBufferL(&cbuff);
UNPROTECT(1);
return(ans);
}
SEXP attribute_hidden complex_math1(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y;
R_xlen_t n;
Rboolean naflag = FALSE;
PROTECT(x = CAR(args));
n = xlength(x);
PROTECT(y = allocVector(CPLXSXP, n));
switch (PRIMVAL(op)) {
case 10003: naflag = cmath1(clog, COMPLEX(x), COMPLEX(y), n); break;
case 3: naflag = cmath1(csqrt, COMPLEX(x), COMPLEX(y), n); break;
case 10: naflag = cmath1(cexp, COMPLEX(x), COMPLEX(y), n); break;
case 20: naflag = cmath1(ccos, COMPLEX(x), COMPLEX(y), n); break;
case 21: naflag = cmath1(csin, COMPLEX(x), COMPLEX(y), n); break;
case 22: naflag = cmath1(z_tan, COMPLEX(x), COMPLEX(y), n); break;
case 23: naflag = cmath1(z_acos, COMPLEX(x), COMPLEX(y), n); break;
case 24: naflag = cmath1(z_asin, COMPLEX(x), COMPLEX(y), n); break;
case 25: naflag = cmath1(z_atan, COMPLEX(x), COMPLEX(y), n); break;
case 30: naflag = cmath1(ccosh, COMPLEX(x), COMPLEX(y), n); break;
case 31: naflag = cmath1(csinh, COMPLEX(x), COMPLEX(y), n); break;
case 32: naflag = cmath1(ctanh, COMPLEX(x), COMPLEX(y), n); break;
case 33: naflag = cmath1(z_acosh, COMPLEX(x), COMPLEX(y), n); break;
case 34: naflag = cmath1(z_asinh, COMPLEX(x), COMPLEX(y), n); break;
case 35: naflag = cmath1(z_atanh, COMPLEX(x), COMPLEX(y), n); break;
default:
/* such as sign, gamma */
errorcall(call, _("unimplemented complex function"));
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
return y;
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y = R_NilValue; /* -Wall*/
R_xlen_t i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = XLENGTH(x);
switch(PRIMVAL(op)) {
case 1: /* Re */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].r;
break;
case 2: /* Im */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].i;
break;
case 3: /* Mod */
case 6: /* abs */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CABS
REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
break;
case 4: /* Arg */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CARG
REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
break;
case 5: /* Conj */
y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
for(i = 0 ; i < n ; i++) {
COMPLEX(y)[i].r = COMPLEX(x)[i].r;
COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
}
break;
}
}
else if(isNumeric(x)) { /* so no complex numbers involved */
n = XLENGTH(x);
if(isReal(x)) PROTECT(x);
else PROTECT(x = coerceVector(x, REALSXP));
y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);
switch(PRIMVAL(op)) {
case 1: /* Re */
case 5: /* Conj */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = REAL(x)[i];
break;
case 2: /* Im */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = 0.0;
break;
case 4: /* Arg */
for(i = 0 ; i < n ; i++)
if(ISNAN(REAL(x)[i]))
REAL(y)[i] = REAL(x)[i];
else if (REAL(x)[i] >= 0)
REAL(y)[i] = 0;
else
REAL(y)[i] = M_PI;
break;
case 3: /* Mod */
case 6: /* abs */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = fabs(REAL(x)[i]);
break;
}
UNPROTECT(1);
}
else errorcall(call, _("non-numeric argument to function"));
if (x != y && ATTRIB(x) != R_NilValue) {
PROTECT(x);
PROTECT(y);
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
}
return y;
}
SEXP track(SEXP args) {
// Skip function name
args = CDR(args);
// Execution mode
SEXP mode = CAR(args);
args = CDR(args);
// Targets
SEXP targetChrom = CAR(args);
args = CDR(args);
int targetStart_int = startTarget(CAR(args));
args = CDR(args);
int targetEnd_int = endTarget(CAR(args));
args = CDR(args);
// Index
SEXP index = CAR(args);
args = CDR(args);
// Extract columns from arguments
SEXP colNames;
SEXP* colSexp;
int colCount = argsColCount(args);
argsColCollect(args, colCount, &colSexp, &colNames);
// Length consistency
int rowCount = LENGTH(colSexp[0]);
for(int i = 1; i < colCount; i++) {
if(LENGTH(colSexp[i]) != rowCount) {
error("All columns must have same lengths");
}
}
// Coordinate columns extraction and check
SEXP chrom, start, end;
coordCollect(colCount, colSexp, colNames, &chrom, &start, &end);
// Chrom consistency
int targetChrom_int = chromTarget(chrom, targetChrom);
// Index search for the chromosome range ('start' is IN the range, 'end' is not)
int chromRangeStart, chromRangeEnd;
if(rowCount > 0) {
if(targetChrom_int != -1) {
// Test index length
if(LENGTH(index) <= targetChrom_int) {
error("The index seems corrupted (looking for a non-existing value)");
}
// Get range end from the index
chromRangeEnd = INTEGER(index)[ targetChrom_int ];
if(chromRangeEnd != NA_INTEGER) {
// Get the end of the previous non NA chromosome
int i = targetChrom_int - 1;
while(i >= 0 && INTEGER(index)[i] == NA_INTEGER) { i--; }
if(i < 0) {
chromRangeStart = 0;
} else {
chromRangeStart = INTEGER(index)[i];
}
} else {
// Level found but not used
chromRangeStart = -1;
chromRangeEnd = -1;
}
} else {
// Not found in levels
chromRangeStart = -1;
chromRangeEnd = -1;
}
} else {
// No row to search in
chromRangeStart = -1;
chromRangeEnd = -1;
}
// Hit count
int outputLength = 0;
if(chromRangeStart != -1) {
for(int i = chromRangeStart; i < chromRangeEnd && INTEGER(start)[i] <= targetEnd_int; i++) {
if(INTEGER(end)[i] >= targetStart_int) {
outputLength++;
}
}
}
// R object to return
SEXP output;
if(strcmp(CHAR(STRING_ELT(mode, 0)), "size") == 0) {
// Count only
PROTECT(output = allocVector(INTSXP, 1));
INTEGER(output)[0] = outputLength;
// Memory release
Free(colSexp);
// Unprotect variables (last action !)
UNPROTECT(2);
} else if(strcmp(CHAR(STRING_ELT(mode, 0)), "sub") == 0) {
// Data frame
PROTECT(output = allocVector(VECSXP, colCount));
// Data frame row names storage
SEXP outRowNames;
PROTECT(outRowNames = allocVector(INTSXP, outputLength));
// Data frame column allocation
for(int i = 0; i < colCount; i++) {
switch(TYPEOF(colSexp[i])) {
case INTSXP:
SET_VECTOR_ELT(output, i, PROTECT(allocVector(INTSXP, outputLength)));
break;
case REALSXP:
SET_VECTOR_ELT(output, i, PROTECT(allocVector(REALSXP, outputLength)));
break;
case LGLSXP:
SET_VECTOR_ELT(output, i, PROTECT(allocVector(LGLSXP, outputLength)));
break;
case STRSXP:
SET_VECTOR_ELT(output, i, PROTECT(allocVector(STRSXP, outputLength)));
break;
default:
error("Unhandled column type");
}
DUPLICATE_ATTRIB(VECTOR_ELT(output, i), colSexp[i]);
}
// Data frame filling
if(chromRangeStart != -1) {
for(int i = chromRangeStart, j = 0; i < chromRangeEnd && INTEGER(start)[i] <= targetEnd_int; i++) {
if(INTEGER(end)[i] >= targetStart_int) {
for(int k = 0; k < colCount; k++) {
switch(TYPEOF(colSexp[k])) {
case INTSXP:
INTEGER(VECTOR_ELT(output, k))[j] = INTEGER(colSexp[k])[i];
break;
case REALSXP:
REAL(VECTOR_ELT(output, k))[j] = REAL(colSexp[k])[i];
break;
case LGLSXP:
LOGICAL(VECTOR_ELT(output, k))[j] = LOGICAL(colSexp[k])[i];
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(output, k), j, STRING_ELT(colSexp[k], i));
break;
default:
error("Unhandled column type");
}
}
INTEGER(outRowNames)[j] = j + 1;
j++;
}
}
}
// Data frame class
SEXP outClass;
PROTECT(outClass = allocVector(STRSXP, 1));
SET_STRING_ELT(outClass, 0, mkChar("data.frame"));
setAttrib(output, R_ClassSymbol, outClass);
// Data frame col names
setAttrib(output, R_NamesSymbol, colNames);
// Data frame row names attribution
setAttrib(output, R_RowNamesSymbol, outRowNames);
// Memory release
Free(colSexp);
// Unprotect variables (last action !)
UNPROTECT(4+colCount);
} else {
error("'mode' argument not handled ('size' or 'sub')");
}
return output;
}
SEXP clahe (SEXP x, SEXP _uiNrX, SEXP _uiNrY, SEXP _uiNrBins, SEXP _fCliplimit, SEXP _keepRange) {
int nx, ny, nz, i, j;
unsigned int uiNrX, uiNrY, uiNrBins;
float fCliplimit;
int keepRange;
double *src, *tgt;
SEXP res;
kz_pixel_t min = 0, max = uiNR_OF_GREY-1;
kz_pixel_t *img;
double maxPixelValue = uiNR_OF_GREY-1;
PROTECT( res = allocVector(REALSXP, XLENGTH(x)) );
DUPLICATE_ATTRIB(res, x);
nx = INTEGER(GET_DIM(x))[0];
ny = INTEGER(GET_DIM(x))[1];
nz = getNumberOfFrames(x, 0);
uiNrX = INTEGER(_uiNrX)[0];
uiNrY = INTEGER(_uiNrY)[0];
uiNrBins = INTEGER(_uiNrBins)[0];
fCliplimit = REAL(_fCliplimit)[0];
keepRange = LOGICAL(_keepRange)[0];
img = R_Calloc(nx*ny, kz_pixel_t);
// process channels separately
for(j = 0; j < nz; j++) {
src = &(REAL(x)[j*nx*ny]);
tgt = &(REAL(res)[j*nx*ny]);
if (keepRange) {
min = uiNR_OF_GREY-1;
max = 0;
}
// convert frame to CLAHE-compatible format
for (i = 0; i < nx*ny; i++) {
double el = src[i];
// clip
if (el < 0.0) el = 0;
else if (el > 1.0) el = 1.0;
// convert to int
kz_pixel_t nel = (kz_pixel_t) round(el * maxPixelValue);
if (keepRange) {
if (nel < min) min = nel;
if (nel > max) max = nel;
}
img[i] = nel;
}
int val = CLAHE (img, (unsigned int) nx, (unsigned int) ny,
min, max, uiNrX, uiNrY, uiNrBins, fCliplimit);
// translate internal error codes
switch (val) {
case -1:
error("# of regions x-direction too large");
break;
case -2:
error("# of regions y-direction too large");
break;
case -3:
error("x-resolution no multiple of 'nx'");
break;
case -4:
error("y-resolution no multiple of 'ny'");
break;
case -5:
error("maximum too large");
break;
case -6:
error("minimum equal or larger than maximum");
break;
case -7:
error("at least 4 contextual regions required");
break;
case -8:
error("not enough memory! (try reducing 'bins')");
break;
}
// convert back to [0:1] range
for (i = 0; i < nx*ny; i++) {
tgt[i] = (double) img[i] / maxPixelValue;
}
}
R_Free(img);
UNPROTECT(1);
return res;
}
/* iconv(x, from, to, sub, mark) */
SEXP attribute_hidden do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, x = CAR(args), si;
void * obj;
const char *inbuf;
char *outbuf;
const char *sub;
size_t inb, outb, res;
R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
Rboolean isRawlist = FALSE;
checkArity(op, args);
if(isNull(x)) { /* list locales */
#ifdef HAVE_ICONVLIST
cnt = 0;
iconvlist(count_one, NULL);
PROTECT(ans = allocVector(STRSXP, cnt));
cnt = 0;
iconvlist(write_one, (void *)ans);
#else
PROTECT(ans = R_NilValue);
#endif
} else {
int mark, toRaw;
const char *from, *to;
Rboolean isLatin1 = FALSE, isUTF8 = FALSE;
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "from");
from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "to");
to = CHAR(STRING_ELT(CAR(args), 0));
args = CDR(args);
if(!isString(CAR(args)) || length(CAR(args)) != 1)
error(_("invalid '%s' argument"), "sub");
if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;
else sub = translateChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
mark = asLogical(CAR(args));
if(mark == NA_LOGICAL)
error(_("invalid '%s' argument"), "mark");
args = CDR(args);
toRaw = asLogical(CAR(args));
if(toRaw == NA_LOGICAL)
error(_("invalid '%s' argument"), "toRaw");
/* some iconv's allow "UTF8", but libiconv does not */
if(streql(from, "UTF8") || streql(from, "utf8") ) from = "UTF-8";
if(streql(to, "UTF8") || streql(to, "utf8") ) to = "UTF-8";
/* Should we do something about marked CHARSXPs in 'from = ""'? */
if(streql(to, "UTF-8")) isUTF8 = TRUE;
if(streql(to, "latin1") || streql(to, "ISO_8859-1")
|| streql(to, "CP1252")) isLatin1 = TRUE;
if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;
if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;
obj = Riconv_open(to, from);
if(obj == (iconv_t)(-1))
#ifdef Win32
error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
from, to, localeCP);
#else
error(_("unsupported conversion from '%s' to '%s'"), from, to);
#endif
isRawlist = (TYPEOF(x) == VECSXP);
if(isRawlist) {
if(toRaw)
PROTECT(ans = duplicate(x));
else {
PROTECT(ans = allocVector(STRSXP, LENGTH(x)));
DUPLICATE_ATTRIB(ans, x);
}
} else {
if(TYPEOF(x) != STRSXP)
error(_("'x' must be a character vector"));
if(toRaw) {
PROTECT(ans = allocVector(VECSXP, LENGTH(x)));
DUPLICATE_ATTRIB(ans, x);
} else
PROTECT(ans = duplicate(x));
}
R_AllocStringBuffer(0, &cbuff); /* 0 -> default */
for(R_xlen_t i = 0; i < XLENGTH(x); i++) {
if (isRawlist) {
si = VECTOR_ELT(x, i);
if (TYPEOF(si) == NILSXP) {
if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
continue;
} else if (TYPEOF(si) != RAWSXP)
error(_("'x' must be a list of NULL or raw vectors"));
} else {
si = STRING_ELT(x, i);
if (si == NA_STRING) {
if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
continue;
}
}
top_of_loop:
inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si);
inb = LENGTH(si);
outbuf = cbuff.data; outb = cbuff.bufsize - 1;
/* First initialize output */
Riconv (obj, NULL, NULL, &outbuf, &outb);
next_char:
/* Then convert input */
res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
*outbuf = '\0';
/* other possible error conditions are incomplete
and invalid multibyte chars */
if(res == -1 && errno == E2BIG) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
} else if(res == -1 && sub &&
(errno == EILSEQ || errno == EINVAL)) {
/* it seems this gets thrown for non-convertible input too */
if(strcmp(sub, "byte") == 0) {
if(outb < 5) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
}
snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
outbuf += 4; outb -= 4;
} else {
size_t j;
if(outb < strlen(sub)) {
R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
goto top_of_loop;
}
memcpy(outbuf, sub, j = strlen(sub));
outbuf += j;
outb -= j;
}
inbuf++; inb--;
goto next_char;
}
if(toRaw) {
if(res != -1 && inb == 0) {
size_t nout = cbuff.bufsize - 1 - outb;
SEXP el = allocVector(RAWSXP, nout);
memcpy(RAW(el), cbuff.data, nout);
SET_VECTOR_ELT(ans, i, el);
} /* otherwise is already NULL */
} else {
if(res != -1 && inb == 0) {
cetype_t ienc = CE_NATIVE;
size_t nout = cbuff.bufsize - 1 - outb;
if(mark) {
if(isLatin1) ienc = CE_LATIN1;
else if(isUTF8) ienc = CE_UTF8;
}
SET_STRING_ELT(ans, i,
mkCharLenCE(cbuff.data, (int) nout, ienc));
} else SET_STRING_ELT(ans, i, NA_STRING);
}
}
Riconv_close(obj);
R_FreeStringBuffer(&cbuff);
}
UNPROTECT(1);
return ans;
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
