/* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka * Copyright (C) 1997-2006 Robert Gentleman, Ross Ihaka and the R core team. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street Fifth Floor, Boston, MA 02110-1301 USA * * * * GRZ-like state information. * * This is a quick knock-off of the GRZ library to provide a basic * S-like graphics capability for R. Basically this bit of code * provides the functionality of the "par" function in S. * * "The horror, the horror ..." * Marlon Brando in Apocalypse Now. * * Main functions: * do_par(.) and * do_layout(.) implement R's par(.), layout()rely on * * Specify(.) [ par(what = value) ] * Specify2(.) [ (what = value) ] * Query(.) [ par(what) ] */ /* char here is either ASCII or handled as a whole */ #ifdef HAVE_CONFIG_H #include #endif #include #include #include /* "GPar" structure + COMMENTS */ #include typedef struct { char *name; int code; /* 0 normal, 1 not inline, 2 read-only -1 unknown, -2 obselete, -3 graphical args */ } ParTab; static ParTab ParTable[] = { { "adj", 0 }, { "ann", 0 }, { "ask", 1 }, { "bg", 0 }, { "bty", 0 }, { "cex", 0 }, { "cex.axis", 0 }, { "cex.lab", 0 }, { "cex.main", 0 }, { "cex.sub", 0 }, { "cin", 2 }, { "col", 0 }, { "col.axis", 0 }, { "col.lab", 0 }, { "col.main", 0 }, { "col.sub", 0 }, { "cra", 2 }, { "crt", 0 }, { "csi", 2 }, { "csy", 0 }, { "cxy", 2 }, { "din", 2 }, { "err", 0 }, { "family", 0 }, { "fg", 0 }, { "fig", 1 }, { "fin", 1 }, { "font", 0 }, { "font.axis", 0 }, { "font.lab", 0 }, { "font.main", 0 }, { "font.sub", 0 }, { "gamma", 0 }, { "lab", 0 }, { "las", 0 }, { "lend", 0 }, { "lheight", 1 }, { "ljoin", 0 }, { "lmitre", 0 }, { "lty", 0 }, { "lwd", 0 }, { "mai", 1 }, { "mar", 1 }, { "mex", 1 }, { "mfcol", 1 }, { "mfg", 1 }, { "mfrow", 1 }, { "mgp", 0 }, { "mkh", 0 }, { "new", 1 }, { "oma", 1 }, { "omd", 1 }, { "omi", 1 }, { "pch", 0 }, { "pin", 1 }, { "plt", 1 }, { "ps", 1 }, { "pty", 1 }, { "smo", 0 }, { "srt", 0 }, { "tck", 0 }, { "tcl", 0 }, { "usr", 1 }, { "xaxp", 0 }, { "xaxs", 0 }, { "xaxt", 0 }, { "xlog", 1 }, { "xpd", 0 }, { "yaxp", 0 }, { "yaxs", 0 }, { "yaxt", 0 }, { "ylog", 1 }, /* Obsolete pars */ { "type", -2}, { "tmag", -2}, /* Non-pars that might get passed to Specify2 */ { "asp", -3}, { "main", -3}, { "sub", -3}, { "xlab", -3}, { "ylab", -3}, { "xlim", -3}, { "ylim", -3}, { NULL, -1} }; static int ParCode(char *what) { int i; for (i = 0; ParTable[i].name; i++) if (!strcmp(what, ParTable[i].name)) return ParTable[i].code; return -1; } #ifdef UNUSED /* par(.)'s call */ static SEXP gcall; void RecordGraphicsCall(SEXP call) { gcall = call; } #endif static void par_error(char *what) { error(_("invalid value specified for graphical parameter \"%s\""), what); } static void lengthCheck(char *what, SEXP v, int n, SEXP call) { if (length(v) != n) errorcall(call, _("graphical parameter \"%s\" has the wrong length"), what); } static void nonnegIntCheck(int x, char *s) { if (x == NA_INTEGER || x < 0) par_error(s); } static void posIntCheck(int x, char *s) { if (x == NA_INTEGER || x <= 0) par_error(s); } #ifdef UNUSED static void naIntCheck(int x, char *s) { if (x == NA_INTEGER) par_error(s); } #endif static void posRealCheck(double x, char *s) { if (!R_FINITE(x) || x <= 0) par_error(s); } static void nonnegRealCheck(double x, char *s) { if (!R_FINITE(x) || x < 0) par_error(s); } static void naRealCheck(double x, char *s) { if (!R_FINITE(x)) par_error(s); } static void logAxpCheck(int x, char *s) { if (x == NA_INTEGER || x == 0 || x > 4) par_error(s); } static void BoundsCheck(double x, double a, double b, char *s) { /* Check if a <= x <= b */ if (!R_FINITE(x) || (R_FINITE(a) && x < a) || (R_FINITE(b) && x > b)) par_error(s); } /* When any one of the layout parameters (which can only be set via */ /* par(...)) is modified, must call GReset() to update the layout and */ /* the transformations between coordinate systems */ /* These will be defined differently for Specify() and Specify2() : */ /* do not need separate macros for a = b = c and b = a = c */ #define R_DEV__(_P_) Rf_dpptr(dd)->_P_ = Rf_gpptr(dd)->_P_ #define R_DEV_2(_P_) Rf_gpptr(dd)->_P_ = Rf_dpptr(dd)->_P_ /* In Emacs : -- only inside Specify() : * (query-replace-regexp "Rf_dpptr(dd)->\\([][A-Za-z0-9]+\\) = Rf_gpptr(dd)->\\(\\1\\)" "R_DEV__(\\1)" nil nil nil) (query-replace-regexp "Rf_gpptr(dd)->\\([][A-Za-z0-9]+\\) = Rf_dpptr(dd)->\\(\\1\\)" "R_DEV_2(\\1)" nil nil nil) */ static void Specify(char *what, SEXP value, DevDesc *dd, SEXP call) { /* 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", * "lend", lheight", "ljoin", "lmitre", * "mai", "mar", "mex", * "mfrow", "mfcol", "mfg", * "new", * "oma", "omd", "omi", * "pin", "plt", "ps", "pty" * "usr", * "xlog", "ylog" */ double x; int ix = 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; } #include "par-common.c" /* ------------ *--- now, these are *different* from "Specify2() use" : */ else if (streql(what, "bg")) { lengthCheck(what, value, 1, call); ix = RGBpar(value, 0); /* naIntCheck(ix, what); */ R_DEV__(bg) = ix; R_DEV__(new) = FALSE; } else if (streql(what, "cex")) { lengthCheck(what, value, 1, call); x = asReal(value); posRealCheck(x, what); R_DEV__(cex) = 1.0; /* ! (highlevel par, i.e. Specify2(), set x ! */ R_DEV__(cexbase) = x; } else if (streql(what, "fg")) { /* par(fg=) sets BOTH "fg" and "col" */ lengthCheck(what, value, 1, call); ix = RGBpar(value, 0); /* naIntCheck(ix, what); */ R_DEV__(col) = R_DEV__(fg) = ix; } /*--- and these are "Specify() only" {i.e. par(nam = val)} : */ else if (streql(what, "ask")) { lengthCheck(what, value, 1, call); ix = asLogical(value); R_DEV__(ask) = (ix == 1);/* NA |-> FALSE */ } else if (streql(what, "fig")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 4, call); 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, "family")) { value = coerceVector(value, STRSXP); lengthCheck(what, value, 1, call); if(strlen(CHAR(STRING_ELT(value, 0))) > 200) error(_("graphical parameter 'family' has a maximum length of 200 bytes")); strncpy(Rf_dpptr(dd)->family, CHAR(STRING_ELT(value, 0)), 201); strncpy(Rf_gpptr(dd)->family, CHAR(STRING_ELT(value, 0)), 201); } else if (streql(what, "fin")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 2, call); 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, call); x = asReal(value); posRealCheck(x, what); R_DEV__(lheight) = x; } else if (streql(what, "mai")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 4, call); 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, call); 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, call); 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, call); 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, call); 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; value = coerceVector(value, INTSXP); np = length(value); if(np != 2 && np != 4) errorcall(call, _("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 = Rf_dpptr(dd)->numrows; ncol = Rf_dpptr(dd)->numcols; if(row <= 0 || row > nrow) errorcall(call, _("parameter \"i\" in \"mfg\" is out of range")); if(col <= 0 || col > ncol) errorcall(call, _("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")); } R_DEV_2(lastFigure) = nrow*ncol; /*R_DEV__(mfind) = 1;*/ /* currentFigure is 1-based */ if(Rf_gpptr(dd)->mfind) Rf_dpptr(dd)->currentFigure = (col-1)*nrow + row; else Rf_dpptr(dd)->currentFigure = (row-1)*ncol + col; /* if (Rf_dpptr(dd)->currentFigure == 0) Rf_dpptr(dd)->currentFigure = Rf_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 (Rf_dpptr(dd)->canClip) GForceClip(dd); } /* mfg */ else if (streql(what, "new")) { lengthCheck(what, value, 1, call); ix = asLogical(value); if(!Rf_gpptr(dd)->state) warning(_("calling par(new=) with no plot")); else R_DEV__(new) = (ix != 0); } /* -- */ else if (streql(what, "oma")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 4, call); 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) = Rf_gpptr(dd)->lastFigure; GReset(dd); } else if (streql(what, "omd")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 4, call); 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) = Rf_gpptr(dd)->lastFigure; GReset(dd); } else if (streql(what, "omi")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 4, call); 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) = Rf_gpptr(dd)->lastFigure; GReset(dd); } /* -- */ else if (streql(what, "pin")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 2, call); 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, call); 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, call); ix = asInteger(value); nonnegIntCheck(ix, what); R_DEV__(ps) = ix; } else if (streql(what, "pty")) { if (!isString(value) || LENGTH(value) < 1) par_error(what); ix = CHAR(STRING_ELT(value, 0))[0]; if (ix == 'm' || ix == 's') { R_DEV__(pty) = ix; R_DEV__(defaultPlot) = TRUE; } else par_error(what); } /* -- */ else if (streql(what, "usr")) { value = coerceVector(value, REALSXP); lengthCheck(what, value, 4, call); 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 (Rf_gpptr(dd)->xlog) { R_DEV_2(logusr[0]) = REAL(value)[0]; R_DEV_2(logusr[1]) = REAL(value)[1]; R_DEV_2(usr[0]) = pow(10., REAL(value)[0]); R_DEV_2(usr[1]) = pow(10., 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 (Rf_gpptr(dd)->ylog) { R_DEV_2(logusr[2]) = REAL(value)[2]; R_DEV_2(logusr[3]) = REAL(value)[3]; R_DEV_2(usr[2]) = pow(10., REAL(value)[2]); R_DEV_2(usr[3]) = pow(10., 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, call); ix = asLogical(value); if (ix == NA_LOGICAL) par_error(what); R_DEV__(xlog) = (ix != 0); } else if (streql(what, "ylog")) { lengthCheck(what, value, 1, call); ix = asLogical(value); if (ix == NA_LOGICAL) par_error(what); R_DEV__(ylog) = (ix != 0); } /* 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 */ /* Specify2 -- parameters as arguments from higher-level graphics functions * -------- * Many things in PARALLEL to Specify(.) * for par()s not valid here, see comment there. */ #undef R_DEV_2 #undef R_DEV__ /* Now defined differently in Specify2() : */ #define R_DEV__(_P_) Rf_gpptr(dd)->_P_ void attribute_hidden Specify2(char *what, SEXP value, DevDesc *dd, SEXP call) { double x; int ix = 0, ptype = ParCode(what); if (ptype == 1 || ptype == -3) { /* 1: these are valid, but not settable inline 3: arguments, not pars */ return; } if (ptype == -2) { warningcall(call, _("graphical parameter \"%s\" is obsolete"), what); return; } if (ptype < 0) { warningcall(call, _("\"%s\" is not a graphical parameter"), what); return; } if (ptype == 2) { warningcall(call, _("graphical parameter \"%s\" cannot be set"), what); return; } #include "par-common.c" /* ------------ * these are *different* from Specify() , i.e., par( = .) use : */ else if (streql(what, "bg")) { /* bg can be a vector of length > 1, so pick off first value (as e.g. pch always did) */ if (!isVector(value) || LENGTH(value) < 1) par_error(what); R_DEV__(bg) = RGBpar(value, 0); } else if (streql(what, "cex")) { /* cex can be a vector of length > 1, so pick off first value (as e.g. pch always did) */ x = asReal(value); posRealCheck(x, what); R_DEV__(cex) = x; /* not setting cexbase here (but in Specify()) */ } else if (streql(what, "family")) { value = coerceVector(value, STRSXP); lengthCheck(what, value, 1, call); if(strlen(CHAR(STRING_ELT(value, 0))) > 200) error(_("graphical parameter 'family' has a maximum length of 200 bytes")); strncpy(Rf_gpptr(dd)->family, CHAR(STRING_ELT(value, 0)), 201); } else if (streql(what, "fg")) { /* highlevel arg `fg = ' does *not* set `col' (as par(fg=.) does!*/ lengthCheck(what, value, 1, call); ix = RGBpar(value, 0); /* naIntCheck(ix, what); */ R_DEV__(fg) = ix; } } /* Specify2 */ /* Do NOT forget to update ../library/base/R/par.R */ /* if you ADD a NEW par !! */ static SEXP Query(char *what, DevDesc *dd) { SEXP value; if (streql(what, "adj")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->adj; } else if (streql(what, "ann")) { value = allocVector(LGLSXP, 1); LOGICAL(value)[0] = (Rf_dpptr(dd)->ann != 0); } else if (streql(what, "ask")) { value = allocVector(LGLSXP, 1); LOGICAL(value)[0] = Rf_dpptr(dd)->ask; } else if (streql(what, "bg")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->bg))); UNPROTECT(1); } else if (streql(what, "bty")) { char buf[2]; PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->bty; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); UNPROTECT(1); } else if (streql(what, "cex")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->cexbase; } else if (streql(what, "cex.main")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->cexmain; } else if (streql(what, "cex.lab")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->cexlab; } else if (streql(what, "cex.sub")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->cexsub; } else if (streql(what, "cex.axis")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->cexaxis; } else if (streql(what, "cin")) { value = allocVector(REALSXP, 2); REAL(value)[0] = Rf_dpptr(dd)->cra[0]*Rf_dpptr(dd)->ipr[0]; REAL(value)[1] = Rf_dpptr(dd)->cra[1]*Rf_dpptr(dd)->ipr[1]; } else if (streql(what, "col")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->col))); UNPROTECT(1); } else if (streql(what, "col.main")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->colmain))); UNPROTECT(1); } else if (streql(what, "col.lab")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->collab))); UNPROTECT(1); } else if (streql(what, "col.sub")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->colsub))); UNPROTECT(1); } else if (streql(what, "col.axis")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->colaxis))); UNPROTECT(1); } else if (streql(what, "cra")) { value = allocVector(REALSXP, 2); REAL(value)[0] = Rf_dpptr(dd)->cra[0]; REAL(value)[1] = Rf_dpptr(dd)->cra[1]; } else if (streql(what, "crt")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->crt; } else if (streql(what, "csi")) { value = allocVector(REALSXP, 1); REAL(value)[0] = GConvertYUnits(1.0, CHARS, INCHES, dd); } else if (streql(what, "cxy")) { value = allocVector(REALSXP, 2); /* == par("cin") / par("pin") : */ REAL(value)[0] = Rf_dpptr(dd)->cra[0]*Rf_dpptr(dd)->ipr[0] / Rf_dpptr(dd)->pin[0] * (Rf_dpptr(dd)->usr[1] - Rf_dpptr(dd)->usr[0]); REAL(value)[1] = Rf_dpptr(dd)->cra[1]*Rf_dpptr(dd)->ipr[1] / Rf_dpptr(dd)->pin[1] * (Rf_dpptr(dd)->usr[3] - Rf_dpptr(dd)->usr[2]); } else if (streql(what, "din")) { value = allocVector(REALSXP, 2); REAL(value)[0] = GConvertXUnits(1.0, NDC, INCHES, dd); REAL(value)[1] = GConvertYUnits(1.0, NDC, INCHES, dd); } else if (streql(what, "err")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->err; } else if (streql(what, "family")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(Rf_dpptr(dd)->family)); UNPROTECT(1); } else if (streql(what, "fg")) { PROTECT(value = allocVector(STRSXP, 1)); SET_STRING_ELT(value, 0, mkChar(col2name(Rf_dpptr(dd)->fg))); UNPROTECT(1); } else if (streql(what, "fig")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->fig[0]; REAL(value)[1] = Rf_dpptr(dd)->fig[1]; REAL(value)[2] = Rf_dpptr(dd)->fig[2]; REAL(value)[3] = Rf_dpptr(dd)->fig[3]; } else if (streql(what, "fin")) { value = allocVector(REALSXP, 2); REAL(value)[0] = Rf_dpptr(dd)->fin[0]; REAL(value)[1] = Rf_dpptr(dd)->fin[1]; } else if (streql(what, "font")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->font; } else if (streql(what, "font.main")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->fontmain; } else if (streql(what, "font.lab")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->fontlab; } else if (streql(what, "font.sub")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->fontsub; } else if (streql(what, "font.axis")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->fontaxis; } else if (streql(what, "gamma")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->gamma; } else if (streql(what, "lab")) { value = allocVector(INTSXP, 3); INTEGER(value)[0] = Rf_dpptr(dd)->lab[0]; INTEGER(value)[1] = Rf_dpptr(dd)->lab[1]; INTEGER(value)[2] = Rf_dpptr(dd)->lab[2]; } else if (streql(what, "las")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->las; } else if (streql(what, "lend")) { value = LENDget(Rf_dpptr(dd)->lend); } else if (streql(what, "lheight")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->lheight; } else if (streql(what, "ljoin")) { value = LJOINget(Rf_dpptr(dd)->ljoin); } else if (streql(what, "lmitre")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->lmitre; } else if (streql(what, "lty")) { value = LTYget(Rf_dpptr(dd)->lty); } else if (streql(what, "lwd")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->lwd; } else if (streql(what, "mai")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->mai[0]; REAL(value)[1] = Rf_dpptr(dd)->mai[1]; REAL(value)[2] = Rf_dpptr(dd)->mai[2]; REAL(value)[3] = Rf_dpptr(dd)->mai[3]; } else if (streql(what, "mar")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->mar[0]; REAL(value)[1] = Rf_dpptr(dd)->mar[1]; REAL(value)[2] = Rf_dpptr(dd)->mar[2]; REAL(value)[3] = Rf_dpptr(dd)->mar[3]; } else if (streql(what, "mex")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->mex; } /* NOTE that if a complex layout has been specified */ /* then this simple information may not be very useful. */ else if (streql(what, "mfrow") || streql(what, "mfcol")) { value = allocVector(INTSXP, 2); INTEGER(value)[0] = Rf_dpptr(dd)->numrows; INTEGER(value)[1] = Rf_dpptr(dd)->numcols; } else if (streql(what, "mfg")) { int row, col; value = allocVector(INTSXP, 4); currentFigureLocation(&row, &col, dd); INTEGER(value)[0] = row+1; INTEGER(value)[1] = col+1; INTEGER(value)[2] = Rf_dpptr(dd)->numrows; INTEGER(value)[3] = Rf_dpptr(dd)->numcols; } else if (streql(what, "mgp")) { value = allocVector(REALSXP, 3); REAL(value)[0] = Rf_dpptr(dd)->mgp[0]; REAL(value)[1] = Rf_dpptr(dd)->mgp[1]; REAL(value)[2] = Rf_dpptr(dd)->mgp[2]; } else if (streql(what, "mkh")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->mkh; } else if (streql(what, "new")) { value = allocVector(LGLSXP, 1); LOGICAL(value)[0] = Rf_dpptr(dd)->new; } else if (streql(what, "oma")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->oma[0]; REAL(value)[1] = Rf_dpptr(dd)->oma[1]; REAL(value)[2] = Rf_dpptr(dd)->oma[2]; REAL(value)[3] = Rf_dpptr(dd)->oma[3]; } else if (streql(what, "omd")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->omd[0]; REAL(value)[1] = Rf_dpptr(dd)->omd[1]; REAL(value)[2] = Rf_dpptr(dd)->omd[2]; REAL(value)[3] = Rf_dpptr(dd)->omd[3]; } else if (streql(what, "omi")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->omi[0]; REAL(value)[1] = Rf_dpptr(dd)->omi[1]; REAL(value)[2] = Rf_dpptr(dd)->omi[2]; REAL(value)[3] = Rf_dpptr(dd)->omi[3]; } else if (streql(what, "pch")) { char buf[2]; if(Rf_dpptr(dd)->pch < ' ' || Rf_dpptr(dd)->pch > 255) { PROTECT(value = allocVector(INTSXP, 1)); INTEGER(value)[0] = Rf_dpptr(dd)->pch; } else { PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->pch; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); } UNPROTECT(1); } else if (streql(what, "pin")) { value = allocVector(REALSXP, 2); REAL(value)[0] = Rf_dpptr(dd)->pin[0]; REAL(value)[1] = Rf_dpptr(dd)->pin[1]; } else if (streql(what, "plt")) { value = allocVector(REALSXP, 4); REAL(value)[0] = Rf_dpptr(dd)->plt[0]; REAL(value)[1] = Rf_dpptr(dd)->plt[1]; REAL(value)[2] = Rf_dpptr(dd)->plt[2]; REAL(value)[3] = Rf_dpptr(dd)->plt[3]; } else if (streql(what, "ps")) { value = allocVector(INTSXP, 1); INTEGER(value)[0] = Rf_dpptr(dd)->ps; } else if (streql(what, "pty")) { char buf[2]; PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->pty; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); UNPROTECT(1); } else if (streql(what, "smo")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->smo; } else if (streql(what, "srt")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->srt; } else if (streql(what, "tck")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->tck; } else if (streql(what, "tcl")) { value = allocVector(REALSXP, 1); REAL(value)[0] = Rf_dpptr(dd)->tcl; } else if (streql(what, "usr")) { value = allocVector(REALSXP, 4); if (Rf_gpptr(dd)->xlog) { REAL(value)[0] = Rf_gpptr(dd)->logusr[0]; REAL(value)[1] = Rf_gpptr(dd)->logusr[1]; } else { REAL(value)[0] = Rf_dpptr(dd)->usr[0]; REAL(value)[1] = Rf_dpptr(dd)->usr[1]; } if (Rf_gpptr(dd)->ylog) { REAL(value)[2] = Rf_gpptr(dd)->logusr[2]; REAL(value)[3] = Rf_gpptr(dd)->logusr[3]; } else { REAL(value)[2] = Rf_dpptr(dd)->usr[2]; REAL(value)[3] = Rf_dpptr(dd)->usr[3]; } } else if (streql(what, "xaxp")) { value = allocVector(REALSXP, 3); REAL(value)[0] = Rf_dpptr(dd)->xaxp[0]; REAL(value)[1] = Rf_dpptr(dd)->xaxp[1]; REAL(value)[2] = Rf_dpptr(dd)->xaxp[2]; } else if (streql(what, "xaxs")) { char buf[2]; PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->xaxs; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); UNPROTECT(1); } else if (streql(what, "xaxt")) { char buf[2]; PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->xaxt; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); UNPROTECT(1); } else if (streql(what, "xlog")) { value = allocVector(LGLSXP, 1); LOGICAL(value)[0] = Rf_dpptr(dd)->xlog; } else if (streql(what, "xpd")) { value = allocVector(LGLSXP, 1); if (Rf_dpptr(dd)->xpd == 2) LOGICAL(value)[0] = NA_LOGICAL; else LOGICAL(value)[0] = Rf_dpptr(dd)->xpd; } else if (streql(what, "yaxp")) { value = allocVector(REALSXP, 3); REAL(value)[0] = Rf_dpptr(dd)->yaxp[0]; REAL(value)[1] = Rf_dpptr(dd)->yaxp[1]; REAL(value)[2] = Rf_dpptr(dd)->yaxp[2]; } else if (streql(what, "yaxs")) { char buf[2]; PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->yaxs; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); UNPROTECT(1); } else if (streql(what, "yaxt")) { char buf[2]; PROTECT(value = allocVector(STRSXP, 1)); buf[0] = Rf_dpptr(dd)->yaxt; buf[1] = '\0'; SET_STRING_ELT(value, 0, mkChar(buf)); UNPROTECT(1); } else if (streql(what, "ylog")) { value = allocVector(LGLSXP, 1); LOGICAL(value)[0] = Rf_dpptr(dd)->ylog; } else if (ParCode(what) == -2) { warning(_("graphical parameter \"%s\" is obsolete"), what); value = R_NilValue; } else { warning(_("\"%s\" is not a graphical parameter"), what); value = R_NilValue; } return value; } SEXP attribute_hidden do_par(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP value; SEXP originalArgs = args; DevDesc *dd; int new_spec, nargs; checkArity(op, args); dd = CurrentDevice(); new_spec = 0; args = CAR(args); nargs = length(args); if (isNewList(args)) { SEXP oldnames, newnames, tag, val; int i; PROTECT(newnames = allocVector(STRSXP, nargs)); PROTECT(value = allocVector(VECSXP, nargs)); oldnames = getAttrib(args, R_NamesSymbol); for (i = 0 ; i < nargs ; i++) { if (oldnames != R_NilValue) tag = STRING_ELT(oldnames, i); else tag = R_NilValue; val = VECTOR_ELT(args, i); if (tag != R_NilValue && CHAR(tag)[0]) { new_spec = 1; SET_VECTOR_ELT(value, i, Query(CHAR(tag), dd)); SET_STRING_ELT(newnames, i, tag); Specify(CHAR(tag), val, dd, call); } else if (isString(val) && length(val) > 0) { tag = STRING_ELT(val, 0); if (tag != R_NilValue && CHAR(tag)[0]) { SET_VECTOR_ELT(value, i, Query(CHAR(tag), dd)); SET_STRING_ELT(newnames, i, tag); } } else { SET_VECTOR_ELT(value, i, R_NilValue); SET_STRING_ELT(newnames, i, R_NilValue); } } setAttrib(value, R_NamesSymbol, newnames); UNPROTECT(2); } else { error(_("invalid argument passed to par()")); return R_NilValue/* -Wall */; } /* should really only do this if specifying new pars ? yes! [MM] */ if (new_spec && GRecording(call, dd)) recordGraphicOperation(op, originalArgs, dd); return value; } SEXP attribute_hidden do_readonlypars(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP result; GEDevDesc *dd; Rboolean canChangeGamma; int nreadonly; checkArity(op, args); dd = GEcurrentDevice(); canChangeGamma = dd->dev->canChangeGamma; if (canChangeGamma) nreadonly = 5; else nreadonly = 6; PROTECT(result = allocVector(STRSXP, nreadonly)); SET_STRING_ELT(result, 0, mkChar("cin")); SET_STRING_ELT(result, 1, mkChar("cra")); SET_STRING_ELT(result, 2, mkChar("csi")); SET_STRING_ELT(result, 3, mkChar("cxy")); SET_STRING_ELT(result, 4, mkChar("din")); if (!canChangeGamma) SET_STRING_ELT(result, 5, mkChar("gamma")); UNPROTECT(1); return result; } /* * Layout was written by Paul Murrell during 1997-1998 as a partial * implementation of ideas in his PhD thesis. The orginal was * written in common lisp provides rather more general capabilities. * * layout( * num.rows, * num.cols, * mat, * num.figures, * col.widths, * row.heights, * cm.widths, * cm.heights, * respect, * respect.mat * ) */ SEXP attribute_hidden do_layout(SEXP call, SEXP op, SEXP args, SEXP env) { int i, j, nrow, ncol, ncmrow, ncmcol; SEXP originalArgs = args; DevDesc *dd; checkArity(op, args); dd = CurrentDevice(); /* num.rows: */ nrow = Rf_dpptr(dd)->numrows = Rf_gpptr(dd)->numrows = INTEGER(CAR(args))[0]; if (nrow > MAX_LAYOUT_ROWS) error(_("too many rows in layout, limit %d"), MAX_LAYOUT_ROWS); args = CDR(args); /* num.cols: */ ncol = Rf_dpptr(dd)->numcols = Rf_gpptr(dd)->numcols = INTEGER(CAR(args))[0]; if (ncol > MAX_LAYOUT_COLS) error(_("too many columns in layout, limit %d"), MAX_LAYOUT_COLS); if (nrow * ncol > MAX_LAYOUT_CELLS) error(_("too many cells in layout, limit %d"), MAX_LAYOUT_CELLS); args = CDR(args); /* mat[i,j] == order[i+j*nrow] : */ for (i = 0; i < nrow * ncol; i++) Rf_dpptr(dd)->order[i] = Rf_gpptr(dd)->order[i] = INTEGER(CAR(args))[i]; args = CDR(args); /* num.figures: */ Rf_dpptr(dd)->currentFigure = Rf_gpptr(dd)->currentFigure = Rf_dpptr(dd)->lastFigure = Rf_gpptr(dd)->lastFigure = INTEGER(CAR(args))[0]; args = CDR(args); /* col.widths: */ for (j = 0; j < ncol; j++) Rf_dpptr(dd)->widths[j] = Rf_gpptr(dd)->widths[j] = REAL(CAR(args))[j]; args = CDR(args); /* row.heights: */ for (i = 0; i < nrow; i++) Rf_dpptr(dd)->heights[i] = Rf_gpptr(dd)->heights[i] = REAL(CAR(args))[i]; args = CDR(args); /* cm.widths: */ ncmcol = length(CAR(args)); for (j = 0; j < ncol; j++) Rf_dpptr(dd)->cmWidths[j] = Rf_gpptr(dd)->cmWidths[j] = 0; for (j = 0; j < ncmcol; j++) { Rf_dpptr(dd)->cmWidths[INTEGER(CAR(args))[j] - 1] = Rf_gpptr(dd)->cmWidths[INTEGER(CAR(args))[j] - 1] = 1; } args = CDR(args); /* cm.heights: */ ncmrow = length(CAR(args)); for (i = 0; i < nrow; i++) Rf_dpptr(dd)->cmHeights[i] = Rf_gpptr(dd)->cmHeights[i] = 0; for (i = 0; i < ncmrow; i++) { Rf_dpptr(dd)->cmHeights[INTEGER(CAR(args))[i] - 1] = Rf_gpptr(dd)->cmHeights[INTEGER(CAR(args))[i]-1] = 1; } args = CDR(args); /* respect = 0 (FALSE), 1 (TRUE), or 2 (matrix) : */ Rf_dpptr(dd)->rspct = Rf_gpptr(dd)->rspct = INTEGER(CAR(args))[0]; args = CDR(args); /* respect.mat */ for (i = 0; i < nrow * ncol; i++) Rf_dpptr(dd)->respect[i] = Rf_gpptr(dd)->respect[i] = INTEGER(CAR(args))[i]; /*------------------------------------------------------*/ if (nrow > 2 || ncol > 2) { Rf_gpptr(dd)->cexbase = Rf_dpptr(dd)->cexbase = 0.66; Rf_gpptr(dd)->mex = Rf_dpptr(dd)->mex = 1.0; } else if (nrow == 2 && ncol == 2) { Rf_gpptr(dd)->cexbase = Rf_dpptr(dd)->cexbase = 0.83; Rf_gpptr(dd)->mex = Rf_dpptr(dd)->mex = 1.0; } else { Rf_gpptr(dd)->cexbase = Rf_dpptr(dd)->cexbase = 1.0; Rf_gpptr(dd)->mex = Rf_dpptr(dd)->mex = 1.0; } Rf_dpptr(dd)->defaultFigure = Rf_gpptr(dd)->defaultFigure = TRUE; Rf_dpptr(dd)->layout = Rf_gpptr(dd)->layout = TRUE; GReset(dd); if (GRecording(call, dd)) recordGraphicOperation(op, originalArgs, dd); return R_NilValue; } /*= Local Variables: **/ /*= mode: C **/ /*= kept-old-versions: 12 **/ /*= kept-new-versions: 30 **/ /*= End: **/