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



	/* zero-based and R-vectors are one-based. */
 
#define checkArity_length					\
    checkArity(op, args);					\
    if(!LENGTH(CAR(args)))					\
	errorcall(call, "argument must have positive length")
 
 
SEXP do_devcontrol(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);

    else if (isString(pch)) {
	ans = allocVector(INTSXP, n);
	for (i = 0; i < n; i++)
	    INTEGER(ans)[i] = CHAR(STRING(pch)[i])[0];
    }
    else error("invalid plotting symbol");
    for (i = 0; i < n; i++) {
	if (INTEGER(ans)[i] < 0)
	    INTEGER(ans)[i] = dflt;
    }
    return ans;

    char *p;
    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    if (length(args) < 3)
	errorcall(call, "at least 3 arguments required");
 
    xlim = CAR(args);
    if (!isNumeric(xlim) || LENGTH(xlim) != 2)
	errorcall(call, "invalid xlim");
    args = CDR(args);
 
    ylim = CAR(args);
    if (!isNumeric(ylim) || LENGTH(ylim) != 2)
	errorcall(call, "invalid ylim");
    args = CDR(args);
 
    logscale = 0;
    log = CAR(args);
    if (!isString(log))

    GSavePars(dd);
    ProcessInlinePars(args, dd);
 
    if (isInteger(xlim)) {
	if (INTEGER(xlim)[0] == NA_INTEGER || INTEGER(xlim)[1] == NA_INTEGER)
	    errorcall(call, "NAs not allowed in xlim");
	xmin = INTEGER(xlim)[0];
	xmax = INTEGER(xlim)[1];
    }
    else {
	if (!R_FINITE(REAL(xlim)[0]) || !R_FINITE(REAL(xlim)[1]))
	    errorcall(call, "need finite xlim values");
	xmin = REAL(xlim)[0];
	xmax = REAL(xlim)[1];
    }
    if (isInteger(ylim)) {
	if (INTEGER(ylim)[0] == NA_INTEGER || INTEGER(ylim)[1] == NA_INTEGER)
	    errorcall(call, "NAs not allowed in ylim");
	ymin = INTEGER(ylim)[0];
	ymax = INTEGER(ylim)[1];
    }
    else {
	if (!R_FINITE(REAL(ylim)[0]) || !R_FINITE(REAL(ylim)[1]))
	    errorcall(call, "need finite ylim values");
	ymin = REAL(ylim)[0];
	ymax = REAL(ylim)[1];
    }
    if ((dd->dp.xlog && (xmin < 0 || xmax < 0)) ||
       (dd->dp.ylog && (ymin < 0 || ymax < 0)))

    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    /* initial checks */
 
    if (length(args) < 3) errorcall(call, "too few arguments");
    GCheckState(dd);
 
    /* required argument "side" */
 
    side = asInteger(CAR(args));

    DevDesc *dd = CurrentDevice();
 
    /* Basic Checks */
    GCheckState(dd);
    if (length(args) < 6)
	errorcall(call, "too few arguments");
 
    sx = R_NilValue;            /* -Wall */
    sy = R_NilValue;            /* -Wall */
 
    /* Required Arguments */

    double xx[2], yy[2];
    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);
 
    xypoints(call, args, &n);
 
    sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);

    int i, n, nxl, nxr, nyb, nyt;
    int ncol, nlty, nborder, xpd;
    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    if (length(args) < 4) errorcall(call, "too few arguments");
    GCheckState(dd);
 
    xypoints(call, args, &n);
    sxl = CAR(args); nxl = length(sxl); args = CDR(args);
    syb = CAR(args); nyb = length(syb); args = CDR(args);

    int code;
    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd, xpd;
    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    if (length(args) < 4) errorcall(call, "too few arguments");
    GCheckState(dd);
 
    xypoints(call, args, &n);
 
    sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);

    sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
    sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);
 
    hlength = asReal(GetPar("length", args));
    if (!R_FINITE(hlength) || hlength <= 0)
	errorcall(call, "invalid head length");
 
    angle = asReal(GetPar("angle", args));
    if (!R_FINITE(angle))
	errorcall(call, "invalid head angle");
 
    code = asInteger(GetPar("code", args));
    if (code == NA_INTEGER || code < 0 || code > 3)
	errorcall(call, "invalid arrow head specification");
 

    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 
    if (length(args) < 2) errorcall(call, "too few arguments");
 
    if (!isNumeric(CAR(args)) || (nx = LENGTH(CAR(args))) <= 0)
	errorcall(call, "first argument invalid");
    sx = CAR(args) = coerceVector(CAR(args), REALSXP);
    args = CDR(args);

    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 
    if (length(args) < 3) errorcall(call, "too few arguments");
 
    sx = R_NilValue;            /* -Wall */
    sy = R_NilValue;            /* -Wall */
 
    sxy = CAR(args);

    args = CDR(args);
 
    PROTECT(pos = coerceVector(CAR(args), INTSXP));
    for (i = 0; i < length(pos); i++)
        if (INTEGER(pos)[i] < 1 || INTEGER(pos)[i] > 4)
	    errorcall(call, "invalid pos value");
    args = CDR(args);
 
    offset = GConvertXUnits(asReal(CAR(args)), CHARS, INCHES, dd);
    args = CDR(args);
 

    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 
    if (length(args) < 9)
	errorcall(call, "too few arguments");
 
    /* Arg1 : text= */
    /* This has been coerced with char.or.expr() */
    text = CAR(args);
    n = ntext = length(text);
    if (ntext <= 0)
	errorcall(call, "zero length \"text\" specified");
    args = CDR(args);
 
    /* Arg2 : side= */
    PROTECT(side = coerceVector(CAR(args), INTSXP));
    nside = length(side);
    if (nside <= 0) errorcall(call, "zero length \"side\" specified");
    if (n < nside) n = nside;
    args = CDR(args);
 
    /* Arg3 : line= */
    PROTECT(line = coerceVector(CAR(args), REALSXP));
    nline = length(line);
    if (nline <= 0) errorcall(call, "zero length \"line\" specified");
    if (n < nline) n = nline;
    args = CDR(args);
 
    /* Arg4 : outer= */
    /* outer == NA => outer <- 0 */
    PROTECT(outer = coerceVector(CAR(args), INTSXP));
    nouter = length(outer);
    if (nouter <= 0) errorcall(call, "zero length \"outer\" specified");
    if (n < nouter) n = nouter;
    args = CDR(args);
 
    /* Arg5 : at= */
    PROTECT(at = coerceVector(CAR(args), REALSXP));
    nat = length(at);
    if (nat <= 0) errorcall(call, "zero length \"at\" specified");
    if (n < nat) n = nat;
    args = CDR(args);
 
    /* Arg6 : adj= */
    PROTECT(adj = coerceVector(CAR(args), REALSXP));
    nadj = length(adj);
    if (nadj <= 0) errorcall(call, "zero length \"adj\" specified");
    if (n < nadj) n = nadj;
    args = CDR(args);
 
    /* Arg7 : cex */
    PROTECT(cex = FixupCex(CAR(args), 1.0));
    ncex = length(cex);
    if (ncex <= 0) errorcall(call, "zero length \"cex\" specified");
    if (n < ncex) n = ncex;
    args = CDR(args);
 
    /* Arg8 : col */
    PROTECT(col = FixupCol(CAR(args), NA_INTEGER));
    ncol = length(col);
    if (ncol <= 0) errorcall(call, "zero length \"col\" specified");
    if (n < ncol) n = ncol;
    args = CDR(args);
 
    /* Arg9 : font */
    PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
    nfont = length(font);
    if (nfont <= 0) errorcall(call, "zero length \"font\" specified");
    if (n < nfont) n = nfont;
    args = CDR(args);
 
    GSavePars(dd);
    ProcessInlinePars(args, dd);

    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 
    if (length(args) < 4) errorcall(call, "too few arguments");
 
    Main = sub = xlab = ylab = R_NilValue;
 
    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
	Main = CAR(args);

    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 
    if (length(args) < 5) errorcall(call, "too few arguments");
 
    if ((a = CAR(args)) != R_NilValue)
	CAR(args) = a = coerceVector(a, REALSXP);
    args = CDR(args);
 

	else {
	    aa = asReal(a);
	    bb = asReal(b);
	}
	if (!R_FINITE(aa) || !R_FINITE(bb))
	    errorcall(call, "\"a\" and \"b\" must be finite");
	dd->gp.col = INTEGER(col)[0];
	dd->gp.lwd = REAL(lwd)[0];
	if (nlty && INTEGER(lty)[0] != NA_INTEGER)
	    dd->gp.lty = INTEGER(lty)[0];
	else

 
    GCheckState(dd);
    GSavePars(dd);
    which = asInteger(CAR(args)); args = CDR(args);
    if (which < 1 || which > 4)
	errorcall(call, "invalid \"which\" specification");
    col= dd->gp.col;	dd->gp.col= NA_INTEGER;
    fg = dd->gp.col;	dd->gp.fg = NA_INTEGER;
    ProcessInlinePars(args, dd);
    if (dd->gp.col == NA_INTEGER) {
	if (dd->gp.fg == NA_INTEGER)

    GCheckState(dd);
 
    checkArity(op, args);
    n = asInteger(CAR(args));
    if (n <= 0 || n == NA_INTEGER)
	error("invalid number of points in locator");
    args = CDR(args);
    if (isString(CAR(args)) && LENGTH(CAR(args)) == 1)
	type = CHAR(STRING(CAR(args))[0])[0];
    else errorcall(call, "invalid plot type");
    PROTECT(x = allocVector(REALSXP, n));
    PROTECT(y = allocVector(REALSXP, n));
    PROTECT(nobs=allocVector(INTSXP,1));
    i = 0;
 

    args = CDR(args); l = CAR(args);
    args = CDR(args); npts = asInteger(CAR(args));
    args = CDR(args); plot = asLogical(CAR(args));
    args = CDR(args); Offset = CAR(args);
    if (npts <= 0 || npts == NA_INTEGER)
	error("invalid number of points in identify");
    if (!isReal(x) || !isReal(y) || !isString(l) || !isReal(Offset))
	errorcall(call, "incorrect argument type");
    if (LENGTH(x) != LENGTH(y) || LENGTH(x) != LENGTH(l))
	errorcall(call, "different argument lengths");
    n = LENGTH(x);
    if (n <= 0) {
	R_Visible = 0;
	return NULL;
    }

    DevDesc *dd = CurrentDevice();
 
    checkArity(op,args);
    str = CAR(args);
    if ((TYPEOF(str) != STRSXP) && (TYPEOF(str) != EXPRSXP))
	errorcall(call, "character or expression first argument expected");
    args = CDR(args);
 
    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)
	errorcall(call, "invalid units");
    args = CDR(args);
 
    if (isNull(CAR(args)))
	cex = dd->gp.cex;
    else if (!R_FINITE(cex = asReal(CAR(args))) || cex <= 0.0)
	errorcall(call, "invalid cex value");
 
    n = LENGTH(str);
    PROTECT(ans = allocVector(REALSXP, n));
    cexsave = dd->gp.cex;
    dd->gp.cex = cex * dd->gp.cexbase;

    checkArity(op, args);
    GCheckState(dd);
 
    str = CAR(args);
    if ((TYPEOF(str) != STRSXP) && (TYPEOF(str) != EXPRSXP))
	errorcall(call, "character or expression first argument expected");
    args = CDR(args);
 
    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)
	errorcall(call, "invalid units");
    args = CDR(args);
 
    if (isNull(CAR(args)))
	cex = dd->gp.cex;
    else if (!R_FINITE(cex = asReal(CAR(args))) || cex <= 0.0)
	errorcall(call, "invalid cex value");
 
    n = LENGTH(str);
    PROTECT(ans = allocVector(REALSXP, n));
    cexsave = dd->gp.cex;
    dd->gp.cex = cex * dd->gp.cexbase;

    DevDesc *dd;
    dd = CurrentDevice();
    GCheckState(dd);
    originalArgs = args;
    if (length(args) < 6)
	errorcall(call, "too few arguments");
    n = asInteger(CAR(args));
    if (n == NA_INTEGER || n < 2)
	goto badargs;
    args = CDR(args);
    if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2 * n)

Rev 6099	Rev 6191
Line 38...	Line 38...
38	`/* zero-based and R-vectors are one-based. */`	38	`/* zero-based and R-vectors are one-based. */`
39		39
40	`#define checkArity_length \`	40	`#define checkArity_length \`
41	`checkArity(op, args); \`	41	`checkArity(op, args); \`
42	`if(!LENGTH(CAR(args))) \`	42	`if(!LENGTH(CAR(args))) \`
43	`errorcall(call, "argument must have positive length\n")`	43	`errorcall(call, "argument must have positive length")`
44		44
45		45
46	`SEXP do_devcontrol(SEXP call, SEXP op, SEXP args, SEXP env)`	46	`SEXP do_devcontrol(SEXP call, SEXP op, SEXP args, SEXP env)`
47	`{`	47	`{`
48	`checkArity(op, args);`	48	`checkArity(op, args);`
Line 163...	Line 163...
163	`else if (isString(pch)) {`	163	`else if (isString(pch)) {`
164	`ans = allocVector(INTSXP, n);`	164	`ans = allocVector(INTSXP, n);`
165	`for (i = 0; i < n; i++)`	165	`for (i = 0; i < n; i++)`
166	`INTEGER(ans)[i] = CHAR(STRING(pch)[i])[0];`	166	`INTEGER(ans)[i] = CHAR(STRING(pch)[i])[0];`
167	`}`	167	`}`
168	`else error("invalid plotting symbol\n");`	168	`else error("invalid plotting symbol");`
169	`for (i = 0; i < n; i++) {`	169	`for (i = 0; i < n; i++) {`
170	`if (INTEGER(ans)[i] < 0)`	170	`if (INTEGER(ans)[i] < 0)`
171	`INTEGER(ans)[i] = dflt;`	171	`INTEGER(ans)[i] = dflt;`
172	`}`	172	`}`
173	`return ans;`	173	`return ans;`
Line 373...	Line 373...
373	`char *p;`	373	`char *p;`
374	`SEXP originalArgs = args;`	374	`SEXP originalArgs = args;`
375	`DevDesc *dd = CurrentDevice();`	375	`DevDesc *dd = CurrentDevice();`
376		376
377	`if (length(args) < 3)`	377	`if (length(args) < 3)`
378	`errorcall(call, "at least 3 arguments required\n");`	378	`errorcall(call, "at least 3 arguments required");`
379		379
380	`xlim = CAR(args);`	380	`xlim = CAR(args);`
381	`if (!isNumeric(xlim) \|\| LENGTH(xlim) != 2)`	381	`if (!isNumeric(xlim) \|\| LENGTH(xlim) != 2)`
382	`errorcall(call, "invalid xlim\n");`	382	`errorcall(call, "invalid xlim");`
383	`args = CDR(args);`	383	`args = CDR(args);`
384		384
385	`ylim = CAR(args);`	385	`ylim = CAR(args);`
386	`if (!isNumeric(ylim) \|\| LENGTH(ylim) != 2)`	386	`if (!isNumeric(ylim) \|\| LENGTH(ylim) != 2)`
387	`errorcall(call, "invalid ylim\n");`	387	`errorcall(call, "invalid ylim");`
388	`args = CDR(args);`	388	`args = CDR(args);`
389		389
390	`logscale = 0;`	390	`logscale = 0;`
391	`log = CAR(args);`	391	`log = CAR(args);`
392	`if (!isString(log))`	392	`if (!isString(log))`
Line 416...	Line 416...
416	`GSavePars(dd);`	416	`GSavePars(dd);`
417	`ProcessInlinePars(args, dd);`	417	`ProcessInlinePars(args, dd);`
418		418
419	`if (isInteger(xlim)) {`	419	`if (isInteger(xlim)) {`
420	`if (INTEGER(xlim)[0] == NA_INTEGER \|\| INTEGER(xlim)[1] == NA_INTEGER)`	420	`if (INTEGER(xlim)[0] == NA_INTEGER \|\| INTEGER(xlim)[1] == NA_INTEGER)`
421	`errorcall(call, "NAs not allowed in xlim\n");`	421	`errorcall(call, "NAs not allowed in xlim");`
422	`xmin = INTEGER(xlim)[0];`	422	`xmin = INTEGER(xlim)[0];`
423	`xmax = INTEGER(xlim)[1];`	423	`xmax = INTEGER(xlim)[1];`
424	`}`	424	`}`
425	`else {`	425	`else {`
426	`if (!R_FINITE(REAL(xlim)[0]) \|\| !R_FINITE(REAL(xlim)[1]))`	426	`if (!R_FINITE(REAL(xlim)[0]) \|\| !R_FINITE(REAL(xlim)[1]))`
427	`errorcall(call, "need finite xlim values\n");`	427	`errorcall(call, "need finite xlim values");`
428	`xmin = REAL(xlim)[0];`	428	`xmin = REAL(xlim)[0];`
429	`xmax = REAL(xlim)[1];`	429	`xmax = REAL(xlim)[1];`
430	`}`	430	`}`
431	`if (isInteger(ylim)) {`	431	`if (isInteger(ylim)) {`
432	`if (INTEGER(ylim)[0] == NA_INTEGER \|\| INTEGER(ylim)[1] == NA_INTEGER)`	432	`if (INTEGER(ylim)[0] == NA_INTEGER \|\| INTEGER(ylim)[1] == NA_INTEGER)`
433	`errorcall(call, "NAs not allowed in ylim\n");`	433	`errorcall(call, "NAs not allowed in ylim");`
434	`ymin = INTEGER(ylim)[0];`	434	`ymin = INTEGER(ylim)[0];`
435	`ymax = INTEGER(ylim)[1];`	435	`ymax = INTEGER(ylim)[1];`
436	`}`	436	`}`
437	`else {`	437	`else {`
438	`if (!R_FINITE(REAL(ylim)[0]) \|\| !R_FINITE(REAL(ylim)[1]))`	438	`if (!R_FINITE(REAL(ylim)[0]) \|\| !R_FINITE(REAL(ylim)[1]))`
439	`errorcall(call, "need finite ylim values\n");`	439	`errorcall(call, "need finite ylim values");`
440	`ymin = REAL(ylim)[0];`	440	`ymin = REAL(ylim)[0];`
441	`ymax = REAL(ylim)[1];`	441	`ymax = REAL(ylim)[1];`
442	`}`	442	`}`
443	`if ((dd->dp.xlog && (xmin < 0 \|\| xmax < 0)) \|\|`	443	`if ((dd->dp.xlog && (xmin < 0 \|\| xmax < 0)) \|\|`
444	`(dd->dp.ylog && (ymin < 0 \|\| ymax < 0)))`	444	`(dd->dp.ylog && (ymin < 0 \|\| ymax < 0)))`
Line 704...	Line 704...
704	`SEXP originalArgs = args;`	704	`SEXP originalArgs = args;`
705	`DevDesc *dd = CurrentDevice();`	705	`DevDesc *dd = CurrentDevice();`
706		706
707	`/* initial checks */`	707	`/* initial checks */`
708		708
709	`if (length(args) < 3) errorcall(call, "too few arguments\n");`	709	`if (length(args) < 3) errorcall(call, "too few arguments");`
710	`GCheckState(dd);`	710	`GCheckState(dd);`
711		711
712	`/* required argument "side" */`	712	`/* required argument "side" */`
713		713
714	`side = asInteger(CAR(args));`	714	`side = asInteger(CAR(args));`
Line 1028...	Line 1028...
1028	`DevDesc *dd = CurrentDevice();`	1028	`DevDesc *dd = CurrentDevice();`
1029		1029
1030	`/* Basic Checks */`	1030	`/* Basic Checks */`
1031	`GCheckState(dd);`	1031	`GCheckState(dd);`
1032	`if (length(args) < 6)`	1032	`if (length(args) < 6)`
1033	`errorcall(call, "too few arguments\n");`	1033	`errorcall(call, "too few arguments");`
1034		1034
1035	`sx = R_NilValue; /* -Wall */`	1035	`sx = R_NilValue; /* -Wall */`
1036	`sy = R_NilValue; /* -Wall */`	1036	`sy = R_NilValue; /* -Wall */`
1037		1037
1038	`/* Required Arguments */`	1038	`/* Required Arguments */`
Line 1267...	Line 1267...
1267	`double xx[2], yy[2];`	1267	`double xx[2], yy[2];`
1268	`int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;`	1268	`int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;`
1269	`SEXP originalArgs = args;`	1269	`SEXP originalArgs = args;`
1270	`DevDesc *dd = CurrentDevice();`	1270	`DevDesc *dd = CurrentDevice();`
1271		1271
1272	`if (length(args) < 4) errorcall(call, "too few arguments\n");`	1272	`if (length(args) < 4) errorcall(call, "too few arguments");`
1273	`GCheckState(dd);`	1273	`GCheckState(dd);`
1274		1274
1275	`xypoints(call, args, &n);`	1275	`xypoints(call, args, &n);`
1276		1276
1277	`sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);`	1277	`sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);`
Line 1335...	Line 1335...
1335	`int i, n, nxl, nxr, nyb, nyt;`	1335	`int i, n, nxl, nxr, nyb, nyt;`
1336	`int ncol, nlty, nborder, xpd;`	1336	`int ncol, nlty, nborder, xpd;`
1337	`SEXP originalArgs = args;`	1337	`SEXP originalArgs = args;`
1338	`DevDesc *dd = CurrentDevice();`	1338	`DevDesc *dd = CurrentDevice();`
1339		1339
1340	`if (length(args) < 4) errorcall(call, "too few arguments\n");`	1340	`if (length(args) < 4) errorcall(call, "too few arguments");`
1341	`GCheckState(dd);`	1341	`GCheckState(dd);`
1342		1342
1343	`xypoints(call, args, &n);`	1343	`xypoints(call, args, &n);`
1344	`sxl = CAR(args); nxl = length(sxl); args = CDR(args);`	1344	`sxl = CAR(args); nxl = length(sxl); args = CDR(args);`
1345	`syb = CAR(args); nyb = length(syb); args = CDR(args);`	1345	`syb = CAR(args); nyb = length(syb); args = CDR(args);`
Line 1407...	Line 1407...
1407	`int code;`	1407	`int code;`
1408	`int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd, xpd;`	1408	`int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd, xpd;`
1409	`SEXP originalArgs = args;`	1409	`SEXP originalArgs = args;`
1410	`DevDesc *dd = CurrentDevice();`	1410	`DevDesc *dd = CurrentDevice();`
1411		1411
1412	`if (length(args) < 4) errorcall(call, "too few arguments\n");`	1412	`if (length(args) < 4) errorcall(call, "too few arguments");`
1413	`GCheckState(dd);`	1413	`GCheckState(dd);`
1414		1414
1415	`xypoints(call, args, &n);`	1415	`xypoints(call, args, &n);`
1416		1416
1417	`sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);`	1417	`sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);`
Line 1419...	Line 1419...
1419	`sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);`	1419	`sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);`
1420	`sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);`	1420	`sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);`
1421		1421
1422	`hlength = asReal(GetPar("length", args));`	1422	`hlength = asReal(GetPar("length", args));`
1423	`if (!R_FINITE(hlength) \|\| hlength <= 0)`	1423	`if (!R_FINITE(hlength) \|\| hlength <= 0)`
1424	`errorcall(call, "invalid head length\n");`	1424	`errorcall(call, "invalid head length");`
1425		1425
1426	`angle = asReal(GetPar("angle", args));`	1426	`angle = asReal(GetPar("angle", args));`
1427	`if (!R_FINITE(angle))`	1427	`if (!R_FINITE(angle))`
1428	`errorcall(call, "invalid head angle\n");`	1428	`errorcall(call, "invalid head angle");`
1429		1429
1430	`code = asInteger(GetPar("code", args));`	1430	`code = asInteger(GetPar("code", args));`
1431	`if (code == NA_INTEGER \|\| code < 0 \|\| code > 3)`	1431	`if (code == NA_INTEGER \|\| code < 0 \|\| code > 3)`
1432	`errorcall(call, "invalid arrow head specification");`	1432	`errorcall(call, "invalid arrow head specification");`
1433		1433
Line 1500...	Line 1500...
1500	`SEXP originalArgs = args;`	1500	`SEXP originalArgs = args;`
1501	`DevDesc *dd = CurrentDevice();`	1501	`DevDesc *dd = CurrentDevice();`
1502		1502
1503	`GCheckState(dd);`	1503	`GCheckState(dd);`
1504		1504
1505	`if (length(args) < 2) errorcall(call, "too few arguments\n");`	1505	`if (length(args) < 2) errorcall(call, "too few arguments");`
1506		1506
1507	`if (!isNumeric(CAR(args)) \|\| (nx = LENGTH(CAR(args))) <= 0)`	1507	`if (!isNumeric(CAR(args)) \|\| (nx = LENGTH(CAR(args))) <= 0)`
1508	`errorcall(call, "first argument invalid");`	1508	`errorcall(call, "first argument invalid");`
1509	`sx = CAR(args) = coerceVector(CAR(args), REALSXP);`	1509	`sx = CAR(args) = coerceVector(CAR(args), REALSXP);`
1510	`args = CDR(args);`	1510	`args = CDR(args);`
Line 1605...	Line 1605...
1605	`SEXP originalArgs = args;`	1605	`SEXP originalArgs = args;`
1606	`DevDesc *dd = CurrentDevice();`	1606	`DevDesc *dd = CurrentDevice();`
1607		1607
1608	`GCheckState(dd);`	1608	`GCheckState(dd);`
1609		1609
1610	`if (length(args) < 3) errorcall(call, "too few arguments\n");`	1610	`if (length(args) < 3) errorcall(call, "too few arguments");`
1611		1611
1612	`sx = R_NilValue; /* -Wall */`	1612	`sx = R_NilValue; /* -Wall */`
1613	`sy = R_NilValue; /* -Wall */`	1613	`sy = R_NilValue; /* -Wall */`
1614		1614
1615	`sxy = CAR(args);`	1615	`sxy = CAR(args);`
Line 1652...	Line 1652...
1652	`args = CDR(args);`	1652	`args = CDR(args);`
1653		1653
1654	`PROTECT(pos = coerceVector(CAR(args), INTSXP));`	1654	`PROTECT(pos = coerceVector(CAR(args), INTSXP));`
1655	`for (i = 0; i < length(pos); i++)`	1655	`for (i = 0; i < length(pos); i++)`
1656	`if (INTEGER(pos)[i] < 1 \|\| INTEGER(pos)[i] > 4)`	1656	`if (INTEGER(pos)[i] < 1 \|\| INTEGER(pos)[i] > 4)`
1657	`errorcall(call, "invalid pos value\n");`	1657	`errorcall(call, "invalid pos value");`
1658	`args = CDR(args);`	1658	`args = CDR(args);`
1659		1659
1660	`offset = GConvertXUnits(asReal(CAR(args)), CHARS, INCHES, dd);`	1660	`offset = GConvertXUnits(asReal(CAR(args)), CHARS, INCHES, dd);`
1661	`args = CDR(args);`	1661	`args = CDR(args);`
1662		1662
Line 1814...	Line 1814...
1814	`DevDesc *dd = CurrentDevice();`	1814	`DevDesc *dd = CurrentDevice();`
1815		1815
1816	`GCheckState(dd);`	1816	`GCheckState(dd);`
1817		1817
1818	`if (length(args) < 9)`	1818	`if (length(args) < 9)`
1819	`errorcall(call, "too few arguments\n");`	1819	`errorcall(call, "too few arguments");`
1820		1820
1821	`/* Arg1 : text= */`	1821	`/* Arg1 : text= */`
1822	`/* This has been coerced with char.or.expr() */`	1822	`/* This has been coerced with char.or.expr() */`
1823	`text = CAR(args);`	1823	`text = CAR(args);`
1824	`n = ntext = length(text);`	1824	`n = ntext = length(text);`
1825	`if (ntext <= 0)`	1825	`if (ntext <= 0)`
1826	`errorcall(call, "zero length \"text\" specified\n");`	1826	`errorcall(call, "zero length \"text\" specified");`
1827	`args = CDR(args);`	1827	`args = CDR(args);`
1828		1828
1829	`/* Arg2 : side= */`	1829	`/* Arg2 : side= */`
1830	`PROTECT(side = coerceVector(CAR(args), INTSXP));`	1830	`PROTECT(side = coerceVector(CAR(args), INTSXP));`
1831	`nside = length(side);`	1831	`nside = length(side);`
1832	`if (nside <= 0) errorcall(call, "zero length \"side\" specified\n");`	1832	`if (nside <= 0) errorcall(call, "zero length \"side\" specified");`
1833	`if (n < nside) n = nside;`	1833	`if (n < nside) n = nside;`
1834	`args = CDR(args);`	1834	`args = CDR(args);`
1835		1835
1836	`/* Arg3 : line= */`	1836	`/* Arg3 : line= */`
1837	`PROTECT(line = coerceVector(CAR(args), REALSXP));`	1837	`PROTECT(line = coerceVector(CAR(args), REALSXP));`
1838	`nline = length(line);`	1838	`nline = length(line);`
1839	`if (nline <= 0) errorcall(call, "zero length \"line\" specified\n");`	1839	`if (nline <= 0) errorcall(call, "zero length \"line\" specified");`
1840	`if (n < nline) n = nline;`	1840	`if (n < nline) n = nline;`
1841	`args = CDR(args);`	1841	`args = CDR(args);`
1842		1842
1843	`/* Arg4 : outer= */`	1843	`/* Arg4 : outer= */`
1844	`/* outer == NA => outer <- 0 */`	1844	`/* outer == NA => outer <- 0 */`
1845	`PROTECT(outer = coerceVector(CAR(args), INTSXP));`	1845	`PROTECT(outer = coerceVector(CAR(args), INTSXP));`
1846	`nouter = length(outer);`	1846	`nouter = length(outer);`
1847	`if (nouter <= 0) errorcall(call, "zero length \"outer\" specified\n");`	1847	`if (nouter <= 0) errorcall(call, "zero length \"outer\" specified");`
1848	`if (n < nouter) n = nouter;`	1848	`if (n < nouter) n = nouter;`
1849	`args = CDR(args);`	1849	`args = CDR(args);`
1850		1850
1851	`/* Arg5 : at= */`	1851	`/* Arg5 : at= */`
1852	`PROTECT(at = coerceVector(CAR(args), REALSXP));`	1852	`PROTECT(at = coerceVector(CAR(args), REALSXP));`
1853	`nat = length(at);`	1853	`nat = length(at);`
1854	`if (nat <= 0) errorcall(call, "zero length \"at\" specified\n");`	1854	`if (nat <= 0) errorcall(call, "zero length \"at\" specified");`
1855	`if (n < nat) n = nat;`	1855	`if (n < nat) n = nat;`
1856	`args = CDR(args);`	1856	`args = CDR(args);`
1857		1857
1858	`/* Arg6 : adj= */`	1858	`/* Arg6 : adj= */`
1859	`PROTECT(adj = coerceVector(CAR(args), REALSXP));`	1859	`PROTECT(adj = coerceVector(CAR(args), REALSXP));`
1860	`nadj = length(adj);`	1860	`nadj = length(adj);`
1861	`if (nadj <= 0) errorcall(call, "zero length \"adj\" specified\n");`	1861	`if (nadj <= 0) errorcall(call, "zero length \"adj\" specified");`
1862	`if (n < nadj) n = nadj;`	1862	`if (n < nadj) n = nadj;`
1863	`args = CDR(args);`	1863	`args = CDR(args);`
1864		1864
1865	`/* Arg7 : cex */`	1865	`/* Arg7 : cex */`
1866	`PROTECT(cex = FixupCex(CAR(args), 1.0));`	1866	`PROTECT(cex = FixupCex(CAR(args), 1.0));`
1867	`ncex = length(cex);`	1867	`ncex = length(cex);`
1868	`if (ncex <= 0) errorcall(call, "zero length \"cex\" specified\n");`	1868	`if (ncex <= 0) errorcall(call, "zero length \"cex\" specified");`
1869	`if (n < ncex) n = ncex;`	1869	`if (n < ncex) n = ncex;`
1870	`args = CDR(args);`	1870	`args = CDR(args);`
1871		1871
1872	`/* Arg8 : col */`	1872	`/* Arg8 : col */`
1873	`PROTECT(col = FixupCol(CAR(args), NA_INTEGER));`	1873	`PROTECT(col = FixupCol(CAR(args), NA_INTEGER));`
1874	`ncol = length(col);`	1874	`ncol = length(col);`
1875	`if (ncol <= 0) errorcall(call, "zero length \"col\" specified\n");`	1875	`if (ncol <= 0) errorcall(call, "zero length \"col\" specified");`
1876	`if (n < ncol) n = ncol;`	1876	`if (n < ncol) n = ncol;`
1877	`args = CDR(args);`	1877	`args = CDR(args);`
1878		1878
1879	`/* Arg9 : font */`	1879	`/* Arg9 : font */`
1880	`PROTECT(font = FixupFont(CAR(args), NA_INTEGER));`	1880	`PROTECT(font = FixupFont(CAR(args), NA_INTEGER));`
1881	`nfont = length(font);`	1881	`nfont = length(font);`
1882	`if (nfont <= 0) errorcall(call, "zero length \"font\" specified\n");`	1882	`if (nfont <= 0) errorcall(call, "zero length \"font\" specified");`
1883	`if (n < nfont) n = nfont;`	1883	`if (n < nfont) n = nfont;`
1884	`args = CDR(args);`	1884	`args = CDR(args);`
1885		1885
1886	`GSavePars(dd);`	1886	`GSavePars(dd);`
1887	`ProcessInlinePars(args, dd);`	1887	`ProcessInlinePars(args, dd);`
Line 1959...	Line 1959...
1959	`SEXP originalArgs = args;`	1959	`SEXP originalArgs = args;`
1960	`DevDesc *dd = CurrentDevice();`	1960	`DevDesc *dd = CurrentDevice();`
1961		1961
1962	`GCheckState(dd);`	1962	`GCheckState(dd);`
1963		1963
1964	`if (length(args) < 4) errorcall(call, "too few arguments\n");`	1964	`if (length(args) < 4) errorcall(call, "too few arguments");`
1965		1965
1966	`Main = sub = xlab = ylab = R_NilValue;`	1966	`Main = sub = xlab = ylab = R_NilValue;`
1967		1967
1968	`if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)`	1968	`if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)`
1969	`Main = CAR(args);`	1969	`Main = CAR(args);`
Line 2071...	Line 2071...
2071	`SEXP originalArgs = args;`	2071	`SEXP originalArgs = args;`
2072	`DevDesc *dd = CurrentDevice();`	2072	`DevDesc *dd = CurrentDevice();`
2073		2073
2074	`GCheckState(dd);`	2074	`GCheckState(dd);`
2075		2075
2076	`if (length(args) < 5) errorcall(call, "too few arguments\n");`	2076	`if (length(args) < 5) errorcall(call, "too few arguments");`
2077		2077
2078	`if ((a = CAR(args)) != R_NilValue)`	2078	`if ((a = CAR(args)) != R_NilValue)`
2079	`CAR(args) = a = coerceVector(a, REALSXP);`	2079	`CAR(args) = a = coerceVector(a, REALSXP);`
2080	`args = CDR(args);`	2080	`args = CDR(args);`
2081		2081
Line 2114...	Line 2114...
2114	`else {`	2114	`else {`
2115	`aa = asReal(a);`	2115	`aa = asReal(a);`
2116	`bb = asReal(b);`	2116	`bb = asReal(b);`
2117	`}`	2117	`}`
2118	`if (!R_FINITE(aa) \|\| !R_FINITE(bb))`	2118	`if (!R_FINITE(aa) \|\| !R_FINITE(bb))`
2119	`errorcall(call, "\"a\" and \"b\" must be finite\n");`	2119	`errorcall(call, "\"a\" and \"b\" must be finite");`
2120	`dd->gp.col = INTEGER(col)[0];`	2120	`dd->gp.col = INTEGER(col)[0];`
2121	`dd->gp.lwd = REAL(lwd)[0];`	2121	`dd->gp.lwd = REAL(lwd)[0];`
2122	`if (nlty && INTEGER(lty)[0] != NA_INTEGER)`	2122	`if (nlty && INTEGER(lty)[0] != NA_INTEGER)`
2123	`dd->gp.lty = INTEGER(lty)[0];`	2123	`dd->gp.lty = INTEGER(lty)[0];`
2124	`else`	2124	`else`
Line 2210...	Line 2210...
2210		2210
2211	`GCheckState(dd);`	2211	`GCheckState(dd);`
2212	`GSavePars(dd);`	2212	`GSavePars(dd);`
2213	`which = asInteger(CAR(args)); args = CDR(args);`	2213	`which = asInteger(CAR(args)); args = CDR(args);`
2214	`if (which < 1 \|\| which > 4)`	2214	`if (which < 1 \|\| which > 4)`
2215	`errorcall(call, "invalid \"which\" specification\n");`	2215	`errorcall(call, "invalid \"which\" specification");`
2216	`col= dd->gp.col; dd->gp.col= NA_INTEGER;`	2216	`col= dd->gp.col; dd->gp.col= NA_INTEGER;`
2217	`fg = dd->gp.col; dd->gp.fg = NA_INTEGER;`	2217	`fg = dd->gp.col; dd->gp.fg = NA_INTEGER;`
2218	`ProcessInlinePars(args, dd);`	2218	`ProcessInlinePars(args, dd);`
2219	`if (dd->gp.col == NA_INTEGER) {`	2219	`if (dd->gp.col == NA_INTEGER) {`
2220	`if (dd->gp.fg == NA_INTEGER)`	2220	`if (dd->gp.fg == NA_INTEGER)`
Line 2245...	Line 2245...
2245	`GCheckState(dd);`	2245	`GCheckState(dd);`
2246		2246
2247	`checkArity(op, args);`	2247	`checkArity(op, args);`
2248	`n = asInteger(CAR(args));`	2248	`n = asInteger(CAR(args));`
2249	`if (n <= 0 \|\| n == NA_INTEGER)`	2249	`if (n <= 0 \|\| n == NA_INTEGER)`
2250	`error("invalid number of points in locator\n");`	2250	`error("invalid number of points in locator");`
2251	`args = CDR(args);`	2251	`args = CDR(args);`
2252	`if (isString(CAR(args)) && LENGTH(CAR(args)) == 1)`	2252	`if (isString(CAR(args)) && LENGTH(CAR(args)) == 1)`
2253	`type = CHAR(STRING(CAR(args))[0])[0];`	2253	`type = CHAR(STRING(CAR(args))[0])[0];`
2254	`else errorcall(call, "invalid plot type\n");`	2254	`else errorcall(call, "invalid plot type");`
2255	`PROTECT(x = allocVector(REALSXP, n));`	2255	`PROTECT(x = allocVector(REALSXP, n));`
2256	`PROTECT(y = allocVector(REALSXP, n));`	2256	`PROTECT(y = allocVector(REALSXP, n));`
2257	`PROTECT(nobs=allocVector(INTSXP,1));`	2257	`PROTECT(nobs=allocVector(INTSXP,1));`
2258	`i = 0;`	2258	`i = 0;`
2259		2259
Line 2315...	Line 2315...
2315	`args = CDR(args); l = CAR(args);`	2315	`args = CDR(args); l = CAR(args);`
2316	`args = CDR(args); npts = asInteger(CAR(args));`	2316	`args = CDR(args); npts = asInteger(CAR(args));`
2317	`args = CDR(args); plot = asLogical(CAR(args));`	2317	`args = CDR(args); plot = asLogical(CAR(args));`
2318	`args = CDR(args); Offset = CAR(args);`	2318	`args = CDR(args); Offset = CAR(args);`
2319	`if (npts <= 0 \|\| npts == NA_INTEGER)`	2319	`if (npts <= 0 \|\| npts == NA_INTEGER)`
2320	`error("invalid number of points in identify\n");`	2320	`error("invalid number of points in identify");`
2321	`if (!isReal(x) \|\| !isReal(y) \|\| !isString(l) \|\| !isReal(Offset))`	2321	`if (!isReal(x) \|\| !isReal(y) \|\| !isString(l) \|\| !isReal(Offset))`
2322	`errorcall(call, "incorrect argument type\n");`	2322	`errorcall(call, "incorrect argument type");`
2323	`if (LENGTH(x) != LENGTH(y) \|\| LENGTH(x) != LENGTH(l))`	2323	`if (LENGTH(x) != LENGTH(y) \|\| LENGTH(x) != LENGTH(l))`
2324	`errorcall(call, "different argument lengths\n");`	2324	`errorcall(call, "different argument lengths");`
2325	`n = LENGTH(x);`	2325	`n = LENGTH(x);`
2326	`if (n <= 0) {`	2326	`if (n <= 0) {`
2327	`R_Visible = 0;`	2327	`R_Visible = 0;`
2328	`return NULL;`	2328	`return NULL;`
2329	`}`	2329	`}`
Line 2521...	Line 2521...
2521	`DevDesc *dd = CurrentDevice();`	2521	`DevDesc *dd = CurrentDevice();`
2522		2522
2523	`checkArity(op,args);`	2523	`checkArity(op,args);`
2524	`str = CAR(args);`	2524	`str = CAR(args);`
2525	`if ((TYPEOF(str) != STRSXP) && (TYPEOF(str) != EXPRSXP))`	2525	`if ((TYPEOF(str) != STRSXP) && (TYPEOF(str) != EXPRSXP))`
2526	`errorcall(call, "character or expression first argument expected\n");`	2526	`errorcall(call, "character or expression first argument expected");`
2527	`args = CDR(args);`	2527	`args = CDR(args);`
2528		2528
2529	`if ((units = asInteger(CAR(args))) == NA_INTEGER \|\| units < 0)`	2529	`if ((units = asInteger(CAR(args))) == NA_INTEGER \|\| units < 0)`
2530	`errorcall(call, "invalid units\n");`	2530	`errorcall(call, "invalid units");`
2531	`args = CDR(args);`	2531	`args = CDR(args);`
2532		2532
2533	`if (isNull(CAR(args)))`	2533	`if (isNull(CAR(args)))`
2534	`cex = dd->gp.cex;`	2534	`cex = dd->gp.cex;`
2535	`else if (!R_FINITE(cex = asReal(CAR(args))) \|\| cex <= 0.0)`	2535	`else if (!R_FINITE(cex = asReal(CAR(args))) \|\| cex <= 0.0)`
2536	`errorcall(call, "invalid cex value\n");`	2536	`errorcall(call, "invalid cex value");`
2537		2537
2538	`n = LENGTH(str);`	2538	`n = LENGTH(str);`
2539	`PROTECT(ans = allocVector(REALSXP, n));`	2539	`PROTECT(ans = allocVector(REALSXP, n));`
2540	`cexsave = dd->gp.cex;`	2540	`cexsave = dd->gp.cex;`
2541	`dd->gp.cex = cex * dd->gp.cexbase;`	2541	`dd->gp.cex = cex * dd->gp.cexbase;`
Line 2563...	Line 2563...
2563	`checkArity(op, args);`	2563	`checkArity(op, args);`
2564	`GCheckState(dd);`	2564	`GCheckState(dd);`
2565		2565
2566	`str = CAR(args);`	2566	`str = CAR(args);`
2567	`if ((TYPEOF(str) != STRSXP) && (TYPEOF(str) != EXPRSXP))`	2567	`if ((TYPEOF(str) != STRSXP) && (TYPEOF(str) != EXPRSXP))`
2568	`errorcall(call, "character or expression first argument expected\n");`	2568	`errorcall(call, "character or expression first argument expected");`
2569	`args = CDR(args);`	2569	`args = CDR(args);`
2570		2570
2571	`if ((units = asInteger(CAR(args))) == NA_INTEGER \|\| units < 0)`	2571	`if ((units = asInteger(CAR(args))) == NA_INTEGER \|\| units < 0)`
2572	`errorcall(call, "invalid units\n");`	2572	`errorcall(call, "invalid units");`
2573	`args = CDR(args);`	2573	`args = CDR(args);`
2574		2574
2575	`if (isNull(CAR(args)))`	2575	`if (isNull(CAR(args)))`
2576	`cex = dd->gp.cex;`	2576	`cex = dd->gp.cex;`
2577	`else if (!R_FINITE(cex = asReal(CAR(args))) \|\| cex <= 0.0)`	2577	`else if (!R_FINITE(cex = asReal(CAR(args))) \|\| cex <= 0.0)`
2578	`errorcall(call, "invalid cex value\n");`	2578	`errorcall(call, "invalid cex value");`
2579		2579
2580	`n = LENGTH(str);`	2580	`n = LENGTH(str);`
2581	`PROTECT(ans = allocVector(REALSXP, n));`	2581	`PROTECT(ans = allocVector(REALSXP, n));`
2582	`cexsave = dd->gp.cex;`	2582	`cexsave = dd->gp.cex;`
2583	`dd->gp.cex = cex * dd->gp.cexbase;`	2583	`dd->gp.cex = cex * dd->gp.cexbase;`
Line 2715...	Line 2715...
2715	`DevDesc *dd;`	2715	`DevDesc *dd;`
2716	`dd = CurrentDevice();`	2716	`dd = CurrentDevice();`
2717	`GCheckState(dd);`	2717	`GCheckState(dd);`
2718	`originalArgs = args;`	2718	`originalArgs = args;`
2719	`if (length(args) < 6)`	2719	`if (length(args) < 6)`
2720	`errorcall(call, "too few arguments\n");`	2720	`errorcall(call, "too few arguments");`
2721	`n = asInteger(CAR(args));`	2721	`n = asInteger(CAR(args));`
2722	`if (n == NA_INTEGER \|\| n < 2)`	2722	`if (n == NA_INTEGER \|\| n < 2)`
2723	`goto badargs;`	2723	`goto badargs;`
2724	`args = CDR(args);`	2724	`args = CDR(args);`
2725	`if (TYPEOF(CAR(args)) != INTSXP \|\| length(CAR(args)) != 2 * n)`	2725	`if (TYPEOF(CAR(args)) != INTSXP \|\| length(CAR(args)) != 2 * n)`

The R Project SVN R

(root)/branches/R-exp-API/src/main/plot.c @ 77458 – Rev 6099 → 6191