SEXP do_palette(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP val, ans;
unsigned int color[COLOR_TABLE_SIZE];
int i, n;
checkArity(op,args);
/* Record the current palette */
PROTECT(ans = allocVector(STRSXP, R_ColorTableSize));
for (i = 0; i < R_ColorTableSize; i++)
SET_STRING_ELT(ans, i, mkChar(col2name(R_ColorTable[i])));
val = CAR(args);
if (!isString(val)) errorcall(call, _("invalid argument type"));
if ((n=length(val)) == 1) {
if (StrMatch("default", CHAR(STRING_ELT(val, 0))))
setpalette(DefaultPalette);
else errorcall(call, _("unknown palette (need >= 2 colors)"));
}
else if (n > 1) {
if (n > COLOR_TABLE_SIZE)
errorcall(call, _("maximum number of colors exceeded"));
for (i = 0; i < n; i++)
color[i] = char2col(CHAR(STRING_ELT(val, i)));
for (i = 0; i < n; i++)
R_ColorTable[i] = color[i];
R_ColorTableSize = n;
}
UNPROTECT(1);
return ans;
}
SEXP devcapture(SEXP args)
{
int i, col, row, nrow, ncol, size;
Rboolean native;
pGEDevDesc gdd = GEcurrentDevice();
int *rint;
SEXP raster, image, idim;
args = CDR(args);
native = asLogical(CAR(args));
if (native != TRUE) native = FALSE;
raster = GECap(gdd);
if (isNull(raster)) /* NULL = unsupported */
return raster;
PROTECT(raster);
if (native) {
setAttrib(raster, R_ClassSymbol, mkString("nativeRaster"));
UNPROTECT(1);
return raster;
}
/* non-native, covert to color strings (this is based on grid.cap) */
size = LENGTH(raster);
nrow = INTEGER(getAttrib(raster, R_DimSymbol))[0];
ncol = INTEGER(getAttrib(raster, R_DimSymbol))[1];
PROTECT(image = allocVector(STRSXP, size));
rint = INTEGER(raster);
for (i = 0; i < size; i++) {
col = i % ncol + 1;
row = i / ncol + 1;
SET_STRING_ELT(image, (col - 1) * nrow + row - 1,
mkChar(col2name(rint[i])));
}
PROTECT(idim = allocVector(INTSXP, 2));
INTEGER(idim)[0] = nrow;
INTEGER(idim)[1] = ncol;
setAttrib(image, R_DimSymbol, idim);
UNPROTECT(3);
return image;
}
