The R Project SVN – R – Diff – /branches/R-noNULLenv/src/main/plot.c

+    }
     return ans;
+}
 /* GetTextArg() : extract from call and possibly set text arguments
- *  ("label", col=, cex=, font=, vfont=)
+ *  ("label", col=, cex=, font=)
+ *
  * Main purpose: Treat things like  title(main = list("This Title", font= 4))
+ *
  * Called from	do_title()  [only, currently]
  */
 static void
 GetTextArg(SEXP call, SEXP spec, SEXP *ptxt,
-	   int *pcol, double *pcex, int *pfont, SEXP *pvfont)
+	   int *pcol, double *pcex, int *pfont)
+{
     int i, n, col, font, colspecd;
     double cex;
-    SEXP txt, vfont, nms;
+    SEXP txt, nms;
     txt	  = R_NilValue;
-    vfont = R_NilValue;
     cex	  = NA_REAL;
     col	  = R_TRANWHITE;
     colspecd = 0;
     font  = NA_INTEGER;
     PROTECT(txt);
+		    }
+		}
 		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "font")) {
 		    font = asInteger(FixupFont(VECTOR_ELT(spec, i), NA_INTEGER));
+		}
-		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "vfont")) {
-		    vfont = FixupVFont(VECTOR_ELT(spec, i));
-		}
 		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "")) {
 		    txt = VECTOR_ELT(spec, i);
 		    if (TYPEOF(txt) == LANGSXP || TYPEOF(txt)==SYMSXP) {
 			UNPROTECT(1);
 			PROTECT(txt = coerceVector(txt, EXPRSXP));
     if (txt != R_NilValue) {
 	*ptxt = txt;
 	if (R_FINITE(cex))	 *pcex	 = cex;
 	if (colspecd)	         *pcol	 = col;
 	if (font != NA_INTEGER)	 *pfont	 = font;
-	if (vfont != R_NilValue) *pvfont = vfont;
+    }
 }/* GetTextArg */
     /* GRAPHICS FUNCTION ENTRY POINTS */
     if (length(args) < 3)
 	errorcall(call, _("at least 3 arguments required"));
     xlim = CAR(args);
     if (!isNumeric(xlim) || LENGTH(xlim) != 2)
-	errorcall(call, _("invalid '%s' value"), "ylim");
+	errorcall(call, _("invalid '%s' value"), "xlim");
     args = CDR(args);
     ylim = CAR(args);
     if (!isNumeric(ylim) || LENGTH(ylim) != 2)
-	errorcall(call, _("invalid '%s' value"), "xlim");
+	errorcall(call, _("invalid '%s' value"), "ylim");
     args = CDR(args);
     logscale = FALSE;
     logarg = CAR(args);
     if (!isString(logarg))
 	pin1 = GConvertXUnits(1.0, NPC, INCHES, dd);
 	pin2 = GConvertYUnits(1.0, NPC, INCHES, dd);
 	xdelta = fabs(xmax - xmin) / asp;
 	ydelta = fabs(ymax - ymin);
 	if(xdelta == 0.0 && ydelta == 0.0) {
-	    /* We really do mean zero: small non-zero values work
+	    /* We really do mean zero: small non-zero values work.
 	       Mimic the behaviour of GScale for the x axis. */
 	    xadd = yadd = ((xmin == 0.0) ? 1 : 0.4) * asp;
 	    xadd *= asp;
 	} else {
 	    xscale = pin1 / xdelta;
+    }
     else { /* asp <= 0 or not finite -- includes logscale ! */
 	GScale(xmin, xmax, 1, dd);
 	GScale(ymin, ymax, 2, dd);
+    }
+    /* GScale set the [xy]axp parameters */
     GMapWin2Fig(dd);
     GRestorePars(dd);
+    /* This has now clobbered the Rf_ggptr settings for coord system */
     /* NOTE: the operation is only recorded if there was no "error" */
     if (GRecording(call, dd))
 	recordGraphicOperation(op, originalArgs, dd);
     return R_NilValue;
+}
+}
 SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env)
+{
     /* axis(side, at, labels, tick, line, pos,
-     *	    outer, font, vfont, lty, lwd, col, padj, ...) */
+     *	    outer, font, lty, lwd, col, padj, ...) */
-    SEXP at, lab, vfont, padj;
+    SEXP at, lab, padj;
     int col, font, lty, npadj;
     int i, n, nint = 0, ntmp, side, *ind, outer, lineoff = 0;
     int istart, iend, incr;
     Rboolean dolabels, doticks, logflag = FALSE;
     Rboolean create_at;
     /* Arity Check */
     /* This is a builtin function, so it should always have */
     /* the correct arity, but it doesn't hurt to be defensive. */
-    if (length(args) < 9)
+    if (length(args) < 12)
 	errorcall(call, _("too few arguments"));
     GCheckState(dd);
     /* Required argument: "side" */
     /* Which side of the plot the axis is to appear on. */
     /* Optional argument: "font" */
     font = asInteger(FixupFont(CAR(args), NA_INTEGER));
     args = CDR(args);
-    /* Optional argument: "vfont" */
-    /* Allows Hershey vector fonts to be used */
-    PROTECT(vfont = FixupVFont(CAR(args)));
-    if (!isNull(vfont)) {
-      warning("vfont not supported for axis();  use par(family) instead");
-    }
-    args = CDR(args);
     /* Optional argument: "lty" */
     lty = asInteger(FixupLty(CAR(args), NA_INTEGER));
     args = CDR(args);
     /* Optional argument: "lwd" */
-    lwd = asReal(FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
+    lwd = asReal(FixupLwd(CAR(args), 1));
     args = CDR(args);
     /* Optional argument: "col" */
     col = asInteger(FixupCol(CAR(args), Rf_gpptr(dd)->fg));
     args = CDR(args);
     npadj = length(padj);
     if (npadj <= 0) errorcall(call, _("zero length 'padj' specified"));
     /* Now we process all the remaining inline par values:
        we need to do it now as x/yaxp are retrieved next.
-       That will set Rf_gpptr, so we update that. */
+       That will set Rf_gpptr, so we update that first - do_plotwindow
+       clobbered the Rf_gpptr settings. */
     GSavePars(dd);
     Rf_gpptr(dd)->xaxp[0] = Rf_dpptr(dd)->xaxp[0];
     Rf_gpptr(dd)->xaxp[1] = Rf_dpptr(dd)->xaxp[1];
     Rf_gpptr(dd)->xaxp[2] = Rf_dpptr(dd)->xaxp[2];
     Rf_gpptr(dd)->yaxp[0] = Rf_dpptr(dd)->yaxp[0];
      * If it is, we just bail out at this point. */
     if (((side == 1 || side == 3) && Rf_gpptr(dd)->xaxt == 'n') ||
 	((side == 2 || side == 4) && Rf_gpptr(dd)->yaxt == 'n')) {
 	GRestorePars(dd);
-	UNPROTECT(5);
+	UNPROTECT(4);
 	return R_NilValue;
+    }
     /* no! we do allow an `lty' argument -- will not be used often though
      *	Rf_gpptr(dd)->lty = LTY_SOLID; */
     Rf_gpptr(dd)->lty = lty;
     Rf_gpptr(dd)->lwd = lwd;
-    /* Override par("xpd") and force clipping to figure region.
+    /* Override par("xpd") and force clipping to device region. */
-     * NOTE: don't override to _reduce_ clipping region */
     Rf_gpptr(dd)->xpd = 2;
     Rf_gpptr(dd)->adj = R_FINITE(hadj) ? hadj : 0.5;
     Rf_gpptr(dd)->font = (font == NA_INTEGER)? Rf_gpptr(dd)->fontaxis : font;
     Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * Rf_gpptr(dd)->cexaxis;
     GMode(0, dd);
     GRestorePars(dd);
     /* NOTE: only record operation if no "error"  */
     if (GRecording(call, dd))
 	recordGraphicOperation(op, originalArgs, dd);
-    UNPROTECT(5); /* lab, vfont, at, lab, padj again */
+    UNPROTECT(4); /* lab, at, lab, padj again */
     return at;
 }/* do_axis */
 SEXP do_plot_xy(SEXP call, SEXP op, SEXP args, SEXP env)
+}
 SEXP do_rect(SEXP call, SEXP op, SEXP args, SEXP env)
+{
-    /* rect(xl, yb, xr, yt, col, border, lty, lwd, xpd, ...) */
+    /* rect(xl, yb, xr, yt, col, border, lty, ...) */
-    SEXP sxl, sxr, syb, syt, sxpd, col, lty, lwd, border;
+    SEXP sxl, sxr, syb, syt, col, lty, lwd, border;
     double *xl, *xr, *yb, *yt, x0, y0, x1, y1;
-    int i, n, nxl, nxr, nyb, nyt, ncol, nlty, nlwd, nborder, xpd;
+    int i, n, nxl, nxr, nyb, nyt, ncol, nlty, nlwd, nborder;
     SEXP originalArgs = args;
     DevDesc *dd = CurrentDevice();
     if (length(args) < 4) errorcall(call, _("too few arguments"));
     GCheckState(dd);
     PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
     nlwd = length(lwd);
     args = CDR(args);
-    sxpd = CAR(args);
-    if (sxpd != R_NilValue)
-	xpd = asInteger(sxpd);
-    else
-	xpd = Rf_gpptr(dd)->xpd;
-    args = CDR(args);
     GSavePars(dd);
     ProcessInlinePars(args, dd, call);
-    if (xpd == NA_INTEGER)
-	Rf_gpptr(dd)->xpd = 2;
-    else
-	Rf_gpptr(dd)->xpd = xpd;
     xl = REAL(sxl);
     xr = REAL(sxr);
     yb = REAL(syb);
     yt = REAL(syt);
+}
 SEXP do_arrows(SEXP call, SEXP op, SEXP args, SEXP env)
+{
-    /* arrows(x0, y0, x1, y1, length, angle, code, col, lty, lwd, xpd) */
+    /* arrows(x0, y0, x1, y1, length, angle, code, col, lty, lwd, ...) */
-    SEXP sx0, sx1, sy0, sy1, sxpd, col, rawcol, lty, lwd;
+    SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
     double *x0, *x1, *y0, *y1;
     double xx0, yy0, xx1, yy1;
     double hlength, angle;
     int code;
-    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd, xpd;
+    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
     SEXP originalArgs = args;
     DevDesc *dd = CurrentDevice();
     if (length(args) < 4) errorcall(call, _("too few arguments"));
     GCheckState(dd);
     code = asInteger(CAR(args));
     if (code == NA_INTEGER || code < 0 || code > 3)
 	errorcall(call, _("invalid arrow head specification"));
     args = CDR(args);
-    /*
-     * Need raw colours to be able to check for NAs
-     * FixupCol converts NAs to fully transparent
-     */
-    rawcol = CAR(args);
-    PROTECT(col = FixupCol(rawcol, R_TRANWHITE));
+    PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
     ncol = LENGTH(col);
     args = CDR(args);
     PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));
     nlty = length(lty);
     args = CDR(args);
-    /* use FixupLwd, as segments() does too! */
-#ifdef R_1_x_y
-    PROTECT(lwd = CAR(args));
-    nlwd = length(lwd);
-    if (nlwd == 0)
-	errorcall(call, _("'lwd' must be numeric of length >=1"));
-#else
     PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
     nlwd = length(lwd);
-#endif
-    args = CDR(args);
-    sxpd = CAR(args);
-    if (sxpd != R_NilValue)
-	xpd = asInteger(sxpd);
-    else
-	xpd = Rf_gpptr(dd)->xpd;
     args = CDR(args);
     GSavePars(dd);
-    if (xpd == NA_INTEGER)
+    ProcessInlinePars(args, dd, call);
-	Rf_gpptr(dd)->xpd = 2;
-    else
-	Rf_gpptr(dd)->xpd = xpd;
     x0 = REAL(sx0);
     y0 = REAL(sy0);
     x1 = REAL(sx1);
     y1 = REAL(sy1);
 	xx1 = x1[i%nx1];
 	yy1 = y1[i%ny1];
 	GConvert(&xx0, &yy0, USER, DEVICE, dd);
 	GConvert(&xx1, &yy1, USER, DEVICE, dd);
 	if (R_FINITE(xx0) && R_FINITE(yy0) && R_FINITE(xx1) && R_FINITE(yy1)) {
-	    if (isNAcol(rawcol, i, ncol))
-		Rf_gpptr(dd)->col = Rf_dpptr(dd)->col;
-	    else
-		Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
+	    Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
-	    if (nlty == 0 || INTEGER(lty)[i % nlty] == NA_INTEGER)
-		Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
-	    else
-		Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
+	    Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
 	    Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
 	    GArrow(xx0, yy0, xx1, yy1, DEVICE,
 		   hlength, angle, code, dd);
+	}
+    }
     GPolygon(n, x, y, USER, fill, border, dd);
+}
 SEXP do_polygon(SEXP call, SEXP op, SEXP args, SEXP env)
+{
-    /* polygon(x, y, col, border, lty, xpd, ...) */
+    /* polygon(x, y, col, border, lty, ...) */
-    SEXP sx, sy, col, border, lty, sxpd;
+    SEXP sx, sy, col, border, lty;
     int nx;
-    int ncol, nborder, nlty, xpd, i, start=0;
+    int ncol, nborder, nlty, i, start=0;
     int num = 0;
     double *x, *y, xx, yy, xold, yold;
     SEXP originalArgs = args;
     DevDesc *dd = CurrentDevice();
     nx = LENGTH(sx);
     PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));	args = CDR(args);
     ncol = LENGTH(col);
-    PROTECT(border = FixupCol(CAR(args), Rf_gpptr(dd)->fg));	args = CDR(args);
+    PROTECT(border = FixupCol(CAR(args), Rf_gpptr(dd)->fg)); args = CDR(args);
     nborder = LENGTH(border);
-    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));	args = CDR(args);
+    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty)); args = CDR(args);
     nlty = length(lty);
-    sxpd = CAR(args);
-    if (sxpd != R_NilValue)
-	xpd = asInteger(sxpd);
-    else
-	xpd = Rf_gpptr(dd)->xpd;
-    args = CDR(args);
     GSavePars(dd);
     ProcessInlinePars(args, dd, call);
-    if (xpd == NA_INTEGER)
-	Rf_gpptr(dd)->xpd = 2;
-    else
-	Rf_gpptr(dd)->xpd = xpd;
     GMode(1, dd);
     x = REAL(sx);
     y = REAL(sy);
     xold = NA_REAL;
+}
 SEXP do_text(SEXP call, SEXP op, SEXP args, SEXP env)
+{
 /* text(xy, labels, adj, pos, offset,
- *	vfont, cex, col, font, xpd, ...)
+ *	vfont, cex, col, font, ...)
  */
-    SEXP sx, sy, sxy, sxpd, txt, adj, pos, cex, col, rawcol, font, vfont;
+    SEXP sx, sy, sxy, txt, adj, pos, cex, col, rawcol, font, vfont;
-    int i, n, npos, ncex, ncol, nfont, ntxt, xpd;
+    int i, n, npos, ncex, ncol, nfont, ntxt;
     double adjx = 0, adjy = 0, offset = 0.5;
     double *x, *y;
     double xx, yy;
     Rboolean vectorFonts = FALSE;
     SEXP string, originalArgs = args;
     PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
     nfont = LENGTH(font);
     args = CDR(args);
-    sxpd = CAR(args); /* xpd: NULL -> par("xpd") */
-    if (sxpd != R_NilValue)
-	xpd = asInteger(sxpd);
-    else
-	xpd = Rf_gpptr(dd)->xpd;
-    args = CDR(args);
     x = REAL(sx);
     y = REAL(sy);
     /* n = LENGTH(sx) = LENGTH(sy) */
     ntxt = LENGTH(txt);
     GSavePars(dd);
     ProcessInlinePars(args, dd, call);
-    Rf_gpptr(dd)->xpd = (xpd == NA_INTEGER)? 2 : xpd;
     GMode(1, dd);
     if (n == 0 && ntxt > 0)
 	errorcall(call, _("no coordinates were supplied"));
     for (i = 0; i < imax2(n,ntxt); i++) {
 	xx = x[i % n];
 	 adj = NA,
 	 padj = NA,
 	 cex = NA,
 	 col = NA,
 	 font = NA,
-	 vfont = NULL,
 	 ...) */
 SEXP do_mtext(SEXP call, SEXP op, SEXP args, SEXP env)
+{
-    SEXP text, side, line, outer, at, adj, padj, cex, col, font, vfont, string;
+    SEXP text, side, line, outer, at, adj, padj, cex, col, font, string;
     SEXP rawcol;
     int ntext, nside, nline, nouter, nat, nadj, npadj, ncex, ncol, nfont;
     Rboolean dirtyplot = FALSE, gpnewsave = FALSE, dpnewsave = FALSE;
     int i, n, fontsave, colsave;
     double cexsave;
     nfont = length(font);
     if (nfont <= 0) errorcall(call, _("zero length 'font' specified"));
     if (n < nfont) n = nfont;
     args = CDR(args);
-    /* Arg11 : vfont */
-    PROTECT(vfont = FixupVFont(CAR(args)));
-    if (!isNull(vfont)) {
-      warning("vfont not supported for mtext();  use par(family) instead");
-    }
-    args = CDR(args);
     GSavePars(dd);
     ProcessInlinePars(args, dd, call);
     /* If we only scribble in the outer margins, */
     /* we don't want to mark the plot as dirty. */
     GRestorePars(dd);
     if (!dirtyplot) {
 	Rf_gpptr(dd)->new = gpnewsave;
 	Rf_dpptr(dd)->new = dpnewsave;
+    }
-    UNPROTECT(11);
+    UNPROTECT(10);
     /* NOTE: only record operation if no "error"  */
     if (GRecording(call, dd))
 	recordGraphicOperation(op, originalArgs, dd);
     return R_NilValue;
    title(main, sub, xlab, ylab,
 	 line, outer,
 	 ...) */
-    SEXP Main, xlab, ylab, sub, vfont, string;
+    SEXP Main, xlab, ylab, sub, string;
     double adj, adjy, cex, offset, line, hpos, vpos, where;
     int col, font, outer;
     int i, n;
     SEXP originalArgs = args;
     DevDesc *dd = CurrentDevice();
     GMode(1, dd);
     if (Main != R_NilValue) {
 	cex = Rf_gpptr(dd)->cexmain;
 	col = Rf_gpptr(dd)->colmain;
 	font = Rf_gpptr(dd)->fontmain;
-	GetTextArg(call, Main, &Main, &col, &cex, &font, &vfont);
+	GetTextArg(call, Main, &Main, &col, &cex, &font);
 	Rf_gpptr(dd)->col = col;
 	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
 	Rf_gpptr(dd)->font = font;
 	if (outer) {
 	    if (R_FINITE(line)) {
+    }
     if (sub != R_NilValue) {
 	cex = Rf_gpptr(dd)->cexsub;
 	col = Rf_gpptr(dd)->colsub;
 	font = Rf_gpptr(dd)->fontsub;
-	GetTextArg(call, sub, &sub, &col, &cex, &font, &vfont);
+	GetTextArg(call, sub, &sub, &col, &cex, &font);
 	Rf_gpptr(dd)->col = col;
 	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
 	Rf_gpptr(dd)->font = font;
 	if (R_FINITE(line))
 	    vpos = line;
+    }
     if (xlab != R_NilValue) {
 	cex = Rf_gpptr(dd)->cexlab;
 	col = Rf_gpptr(dd)->collab;
 	font = Rf_gpptr(dd)->fontlab;
-	GetTextArg(call, xlab, &xlab, &col, &cex, &font, &vfont);
+	GetTextArg(call, xlab, &xlab, &col, &cex, &font);
 	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
 	Rf_gpptr(dd)->col = col;
 	Rf_gpptr(dd)->font = font;
 	if (R_FINITE(line))
 	    vpos = line;
+    }
     if (ylab != R_NilValue) {
 	cex = Rf_gpptr(dd)->cexlab;
 	col = Rf_gpptr(dd)->collab;
 	font = Rf_gpptr(dd)->fontlab;
-	GetTextArg(call, ylab, &ylab, &col, &cex, &font, &vfont);
+	GetTextArg(call, ylab, &ylab, &col, &cex, &font);
 	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
 	Rf_gpptr(dd)->col = col;
 	Rf_gpptr(dd)->font = font;
 	if (R_FINITE(line))
 	    vpos = line;

The R Project SVN R

(root)/branches/R-noNULLenv/src/main/plot.c @ 34412 – Rev 36017 → 36167