in source/src/library/graphics/src/par.c [234:639]
static void Specify(const char *what, SEXP value, pGEDevDesc dd)
{
/* If you ADD a NEW par, then do NOT forget to update the code in
* ../library/base/R/par.R
* Parameters in Specify(),
* which can*not* be specified in high-level functions,
* i.e., by Specify2() [below]:
* this list is in \details{.} of ../library/base/man/par.Rd
* ------------------------
* "ask",
* "family", "fig", "fin",
* "lheight",
* "mai", "mar", "mex", "mfrow", "mfcol", "mfg",
* "new",
* "oma", "omd", "omi",
* "pin", "plt", "ps", "pty"
* "usr",
* "xlog", "ylog"
* "ylbias",
*/
double x;
int ix = 0;
char cx = '\0';
/* If we get here, Query has already checked that 'what' is valid */
if (ParCode(what) == 2) {
warning(_("graphical parameter \"%s\" cannot be set"), what);
return;
}
#define FOR_PAR
#include "par-common.c"
#undef FOR_PAR
/* ------------ */
else if (streql(what, "bg")) {
lengthCheck(what, value, 1);
ix = RGBpar3(value, 0, dpptr(dd)->bg);
/* naIntCheck(ix, what); */
R_DEV__(bg) = ix;
R_DEV__(new) = FALSE;
}
/*--- and these are "Specify() only" {i.e. par(nam = val)} : */
else if (streql(what, "ask")) {
lengthCheck(what, value, 1); ix = asLogical(value);
dd->ask = (ix == 1);/* NA |-> FALSE */
}
else if (streql(what, "fig")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
if (0.0 <= REAL(value)[0] && REAL(value)[0] < REAL(value)[1] &&
REAL(value)[1] <= 1.0 &&
0.0 <= REAL(value)[2] && REAL(value)[2] < REAL(value)[3] &&
REAL(value)[3] <= 1.0) {
R_DEV_2(defaultFigure) = 0;
R_DEV_2(fUnits) = NIC;
R_DEV_2(numrows) = 1;
R_DEV_2(numcols) = 1;
R_DEV_2(heights[0]) = 1;
R_DEV_2(widths[0]) = 1;
R_DEV_2(cmHeights[0]) = 0;
R_DEV_2(cmWidths[0]) = 0;
R_DEV_2(order[0]) = 1;
R_DEV_2(currentFigure) = 1;
R_DEV_2(lastFigure) = 1;
R_DEV__(rspct) = 0;
R_DEV_2(fig[0]) = REAL(value)[0];
R_DEV_2(fig[1]) = REAL(value)[1];
R_DEV_2(fig[2]) = REAL(value)[2];
R_DEV_2(fig[3]) = REAL(value)[3];
GReset(dd);
}
else par_error(what);
}
else if (streql(what, "fin")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 2);
R_DEV_2(defaultFigure) = 0;
R_DEV_2(fUnits) = INCHES;
R_DEV_2(numrows) = 1;
R_DEV_2(numcols) = 1;
R_DEV_2(heights[0]) = 1;
R_DEV_2(widths[0]) = 1;
R_DEV_2(cmHeights[0]) = 0;
R_DEV_2(cmWidths[0]) = 0;
R_DEV_2(order[0]) = 1;
R_DEV_2(currentFigure) = 1;
R_DEV_2(lastFigure) = 1;
R_DEV__(rspct) = 0;
R_DEV_2(fin[0]) = REAL(value)[0];
R_DEV_2(fin[1]) = REAL(value)[1];
GReset(dd);
}
/* -- */
else if (streql(what, "lheight")) {
lengthCheck(what, value, 1);
x = asReal(value);
posRealCheck(x, what);
R_DEV__(lheight) = x;
}
else if (streql(what, "mai")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
nonnegRealCheck(REAL(value)[0], what);
nonnegRealCheck(REAL(value)[1], what);
nonnegRealCheck(REAL(value)[2], what);
nonnegRealCheck(REAL(value)[3], what);
R_DEV__(mai[0]) = REAL(value)[0];
R_DEV__(mai[1]) = REAL(value)[1];
R_DEV__(mai[2]) = REAL(value)[2];
R_DEV__(mai[3]) = REAL(value)[3];
R_DEV__(mUnits) = INCHES;
R_DEV__(defaultPlot) = TRUE;
GReset(dd);
}
else if (streql(what, "mar")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
nonnegRealCheck(REAL(value)[0], what);
nonnegRealCheck(REAL(value)[1], what);
nonnegRealCheck(REAL(value)[2], what);
nonnegRealCheck(REAL(value)[3], what);
R_DEV__(mar[0]) = REAL(value)[0];
R_DEV__(mar[1]) = REAL(value)[1];
R_DEV__(mar[2]) = REAL(value)[2];
R_DEV__(mar[3]) = REAL(value)[3];
R_DEV__(mUnits) = LINES;
R_DEV__(defaultPlot) = TRUE;
GReset(dd);
}
else if (streql(what, "mex")) {
lengthCheck(what, value, 1); x = asReal(value);
posRealCheck(x, what);
R_DEV__(mex) = x;
GReset(dd);
}
else if (streql(what, "mfrow")) {
int nrow, ncol;
value = coerceVector(value, INTSXP);
lengthCheck(what, value, 2);
posIntCheck(INTEGER(value)[0], what);
posIntCheck(INTEGER(value)[1], what);
nrow = INTEGER(value)[0];
ncol = INTEGER(value)[1];
R_DEV_2(numrows) = nrow;
R_DEV_2(numcols) = ncol;
R_DEV_2(currentFigure) = nrow*ncol;
R_DEV_2(lastFigure) = nrow*ncol;
R_DEV_2(defaultFigure) = TRUE;
R_DEV_2(layout) = FALSE;
if (nrow > 2 || ncol > 2) {
R_DEV_2(cexbase) = 0.66;
R_DEV_2(mex) = 1.0;
}
else if (nrow == 2 && ncol == 2) {
R_DEV_2(cexbase) = 0.83;
R_DEV_2(mex) = 1.0;
}
else {
R_DEV_2(cexbase) = 1.0;
R_DEV_2(mex) = 1.0;
}
R_DEV__(mfind) = 0;
GReset(dd);
}
else if (streql(what, "mfcol")) {
int nrow, ncol;
value = coerceVector(value, INTSXP);
lengthCheck(what, value, 2);
posIntCheck(INTEGER(value)[0], what);
posIntCheck(INTEGER(value)[1], what);
nrow = INTEGER(value)[0];
ncol = INTEGER(value)[1];
R_DEV_2(numrows) = nrow;
R_DEV_2(numcols) = ncol;
R_DEV_2(currentFigure) = nrow*ncol;
R_DEV_2(lastFigure) = nrow*ncol;
R_DEV_2(defaultFigure) = TRUE;
R_DEV_2(layout) = FALSE;
if (nrow > 2 || ncol > 2) {
R_DEV_2(cexbase) = 0.66;
R_DEV_2(mex) = 1.0;
}
else if (nrow == 2 && ncol == 2) {
R_DEV_2(cexbase) = 0.83;
R_DEV_2(mex) = 1.0;
}
else {
R_DEV__(cexbase) = 1.0;
R_DEV__(mex) = 1.0;
}
R_DEV__(mfind) = 1;
GReset(dd);
}
else if (streql(what, "mfg")) {
int row, col, nrow, ncol, np;
PROTECT(value = coerceVector(value, INTSXP));
np = length(value);
if(np != 2 && np != 4)
error(_("parameter \"mfg\" has the wrong length"));
posIntCheck(INTEGER(value)[0], what);
posIntCheck(INTEGER(value)[1], what);
row = INTEGER(value)[0];
col = INTEGER(value)[1];
nrow = dpptr(dd)->numrows;
ncol = dpptr(dd)->numcols;
if(row <= 0 || row > nrow)
error(_("parameter \"i\" in \"mfg\" is out of range"));
if(col <= 0 || col > ncol)
error(_("parameter \"j\" in \"mfg\" is out of range"));
if(np == 4) {
posIntCheck(INTEGER(value)[2], what);
posIntCheck(INTEGER(value)[3], what);
if(nrow != INTEGER(value)[2])
warning(_("value of 'nr' in \"mfg\" is wrong and will be ignored"));
if(ncol != INTEGER(value)[3])
warning(_("value of 'nc' in \"mfg\" is wrong and will be ignored"));
}
UNPROTECT(1);
R_DEV_2(lastFigure) = nrow*ncol;
/*R_DEV__(mfind) = 1;*/
/* currentFigure is 1-based */
if(gpptr(dd)->mfind)
dpptr(dd)->currentFigure = (col-1)*nrow + row;
else dpptr(dd)->currentFigure = (row-1)*ncol + col;
/*
if (dpptr(dd)->currentFigure == 0)
dpptr(dd)->currentFigure = dpptr(dd)->lastFigure;
*/
R_DEV_2(currentFigure);
/* R_DEV_2(defaultFigure) = TRUE;
R_DEV_2(layout) = FALSE; */
R_DEV_2(new) = TRUE;
GReset(dd);
/* Force a device clip */
if (dd->dev->canClip) GForceClip(dd);
} /* mfg */
else if (streql(what, "new")) {
lengthCheck(what, value, 1);
ix = asLogical(value);
if(!gpptr(dd)->state) {
/* no need to warn with new=FALSE and no plot */
if(ix != 0) warning(_("calling par(new=TRUE) with no plot"));
} else R_DEV__(new) = (ix != 0);
}
/* -- */
else if (streql(what, "oma")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
nonnegRealCheck(REAL(value)[0], what);
nonnegRealCheck(REAL(value)[1], what);
nonnegRealCheck(REAL(value)[2], what);
nonnegRealCheck(REAL(value)[3], what);
R_DEV__(oma[0]) = REAL(value)[0];
R_DEV__(oma[1]) = REAL(value)[1];
R_DEV__(oma[2]) = REAL(value)[2];
R_DEV__(oma[3]) = REAL(value)[3];
R_DEV__(oUnits) = LINES;
/* !!! Force eject of multiple figures !!! */
R_DEV__(currentFigure) = gpptr(dd)->lastFigure;
GReset(dd);
}
else if (streql(what, "omd")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
BoundsCheck(REAL(value)[0], 0.0, 1.0, what);
BoundsCheck(REAL(value)[1], 0.0, 1.0, what);
BoundsCheck(REAL(value)[2], 0.0, 1.0, what);
BoundsCheck(REAL(value)[3], 0.0, 1.0, what);
R_DEV__(omd[0]) = REAL(value)[0];
R_DEV__(omd[1]) = REAL(value)[1];
R_DEV__(omd[2]) = REAL(value)[2];
R_DEV__(omd[3]) = REAL(value)[3];
R_DEV__(oUnits) = NDC;
/* Force eject of multiple figures */
R_DEV__(currentFigure) = gpptr(dd)->lastFigure;
GReset(dd);
}
else if (streql(what, "omi")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
nonnegRealCheck(REAL(value)[0], what);
nonnegRealCheck(REAL(value)[1], what);
nonnegRealCheck(REAL(value)[2], what);
nonnegRealCheck(REAL(value)[3], what);
R_DEV__(omi[0]) = REAL(value)[0];
R_DEV__(omi[1]) = REAL(value)[1];
R_DEV__(omi[2]) = REAL(value)[2];
R_DEV__(omi[3]) = REAL(value)[3];
R_DEV__(oUnits) = INCHES;
/* Force eject of multiple figures */
R_DEV__(currentFigure) = gpptr(dd)->lastFigure;
GReset(dd);
}
/* -- */
else if (streql(what, "pin")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 2);
nonnegRealCheck(REAL(value)[0], what);
nonnegRealCheck(REAL(value)[1], what);
R_DEV__(pin[0]) = REAL(value)[0];
R_DEV__(pin[1]) = REAL(value)[1];
R_DEV__(pUnits) = INCHES;
R_DEV__(defaultPlot) = FALSE;
GReset(dd);
}
else if (streql(what, "plt")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
nonnegRealCheck(REAL(value)[0], what);
nonnegRealCheck(REAL(value)[1], what);
nonnegRealCheck(REAL(value)[2], what);
nonnegRealCheck(REAL(value)[3], what);
R_DEV__(plt[0]) = REAL(value)[0];
R_DEV__(plt[1]) = REAL(value)[1];
R_DEV__(plt[2]) = REAL(value)[2];
R_DEV__(plt[3]) = REAL(value)[3];
R_DEV__(pUnits) = NFC;
R_DEV__(defaultPlot) = FALSE;
GReset(dd);
}
else if (streql(what, "ps")) {
lengthCheck(what, value, 1); ix = asInteger(value);
nonnegIntCheck(ix, what);
R_DEV__(ps) = ix;
}
else if (streql(what, "pty")) {
if (!isString(value) || LENGTH(value) < 1)
par_error(what);
cx = CHAR(STRING_ELT(value, 0))[0];
if (cx == 'm' || cx == 's') {
R_DEV__(pty) = cx;
R_DEV__(defaultPlot) = TRUE;
}
else par_error(what);
}
/* -- */
else if (streql(what, "usr")) {
value = coerceVector(value, REALSXP);
lengthCheck(what, value, 4);
naRealCheck(REAL(value)[0], what);
naRealCheck(REAL(value)[1], what);
naRealCheck(REAL(value)[2], what);
naRealCheck(REAL(value)[3], what);
if (REAL(value)[0] == REAL(value)[1] ||
REAL(value)[2] == REAL(value)[3])
par_error(what);
if (gpptr(dd)->xlog) {
R_DEV_2(logusr[0]) = REAL(value)[0];
R_DEV_2(logusr[1]) = REAL(value)[1];
R_DEV_2(usr[0]) = Rexp10(REAL(value)[0]);
R_DEV_2(usr[1]) = Rexp10(REAL(value)[1]);
}
else {
R_DEV_2(usr[0]) = REAL(value)[0];
R_DEV_2(usr[1]) = REAL(value)[1];
R_DEV_2(logusr[0]) = R_Log10(REAL(value)[0]);
R_DEV_2(logusr[1]) = R_Log10(REAL(value)[1]);
}
if (gpptr(dd)->ylog) {
R_DEV_2(logusr[2]) = REAL(value)[2];
R_DEV_2(logusr[3]) = REAL(value)[3];
R_DEV_2(usr[2]) = Rexp10(REAL(value)[2]);
R_DEV_2(usr[3]) = Rexp10(REAL(value)[3]);
}
else {
R_DEV_2(usr[2]) = REAL(value)[2];
R_DEV_2(usr[3]) = REAL(value)[3];
R_DEV_2(logusr[2]) = R_Log10(REAL(value)[2]);
R_DEV_2(logusr[3]) = R_Log10(REAL(value)[3]);
}
/* Reset Mapping and Axis Parameters */
GMapWin2Fig(dd);
GSetupAxis(1, dd);
GSetupAxis(2, dd);
}/* usr */
else if (streql(what, "xlog")) {
lengthCheck(what, value, 1); ix = asLogical(value);
if (ix == NA_LOGICAL)
par_error(what);
R_DEV__(xlog) = (ix != 0);
}
else if (streql(what, "ylog")) {
lengthCheck(what, value, 1); ix = asLogical(value);
if (ix == NA_LOGICAL)
par_error(what);
R_DEV__(ylog) = (ix != 0);
}
else if (streql(what, "ylbias")) {
lengthCheck(what, value, 1);
dd->dev->yLineBias = asReal(value);
}
/* We do not need these as Query will already have warned.
else if (streql(what, "type")) {
warning(_("graphical parameter \"%s\" is obsolete"), what);
}
else warning(_("unknown graphical parameter \"%s\""), what);
*/
return;
} /* Specify */