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



#include "Graphics.h"
#include "Print.h"
 
void NewFrameConfirm()
{
    unsigned char buf[16];
    R_ReadConsole("Hit <Return> to see next plot: ", buf, 16, 0);
}
 
	/* Remember: +1 and/or -1 because C arrays are */
	/* zero-based and R-vectors are one-based. */

    }
    else if (isInteger(font) || isLogical(font)) {
	ans = allocVector(INTSXP, n);
	for (i = 0; i < n; i++) {
	    k = INTEGER(font)[i];
#ifndef Win32
	    if (k < 1 || k > 4) k = NA_INTEGER;
#else
	    if (k < 1 || k > 32) k = NA_INTEGER;
#endif
	    INTEGER(ans)[i] = k;
	}
    }
    else if (isReal(font)) {
	ans = allocVector(INTSXP, n);
	for (i = 0; i < n; i++) {
	    k = REAL(font)[i];
#ifndef Win32
	    if (k < 1 || k > 4) k = NA_INTEGER;
#else
	    if (k < 1 || k > 32) k = NA_INTEGER;
#endif
	    INTEGER(ans)[i] = k;
	}
    }
    else error("invalid font specification");
    return ans;

 *	plot points or lines of various types
 */
    SEXP sxy, sx, sy, pch, cex, col, bg, lty;
    double *x, *y, xold, yold, xx, yy, thiscex;
    int i, n, npch, ncex, ncol, nbg, nlty, type=0, start=0, thispch, thiscol;
 
    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    /* Basic Checks */
    GCheckState(dd);

 
    /* Default col was NA_INTEGER (0x80000000) which was interpreted
       as zero (black) or "don't draw" depending on line/rect/circle
       situation. Now we set the default to zero and don't plot at all
       if col==NA.
 
       FIXME: bg needs similar change, but that requires changes to
       the specific drivers. */
 
    PROTECT(col = FixupCol(CAR(args), 0)); args = CDR(args);
    ncol = LENGTH(col);
 
    PROTECT(bg = FixupCol(CAR(args), NA_INTEGER));	args = CDR(args);
    nbg = LENGTH(bg);
 

	for (i = 0; i < n; i++) {
	    xx = x[i];
	    yy = y[i];
	    GConvert(&xx, &yy, USER, DEVICE, dd);
	    if (R_FINITE(xx) && R_FINITE(yy)) {
		if (R_FINITE(thiscex = REAL(cex)[i % ncex])
		    && (thispch = INTEGER(pch)[i % npch]) != NA_INTEGER
		    && (thiscol = INTEGER(col)[i % ncol]) != NA_INTEGER)
		{
		    dd->gp.cex = thiscex * dd->gp.cexbase;
		    dd->gp.col = thiscol;

}
 
 
SEXP do_segments(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* segments(x0, y0, x1, y1, col, lty, lwd, ...) */
    SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
    double *x0, *x1, *y0, *y1;
    double xx[2], yy[2];
    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
    SEXP originalArgs = args;

}
 
 
SEXP do_rect(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* rect(xl, yb, xr, yt, col, border, lty, lwd, xpd) */
    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;
    SEXP originalArgs = args;
    DevDesc *dd = CurrentDevice();
 
    if (length(args) < 4) errorcall(call, "too few arguments");
    GCheckState(dd);

    nborder = LENGTH(border);
 
    PROTECT(lty = FixupLty(GetPar("lty", args), dd->gp.lty));
    nlty = length(lty);
 
    PROTECT(lwd = FixupLwd(GetPar("lwd", args), dd->gp.lwd));
    nlwd = length(lwd);
 
    xpd = asInteger(GetPar("xpd", args));
 
    GSavePars(dd);
 
    if (xpd == NA_INTEGER)

    yt = REAL(syt);
 
    GMode(1, dd);
    for (i = 0; i < n; i++) {
	if (nlty && INTEGER(lty)[i % nlty] != NA_INTEGER)
	    dd->gp.lty = INTEGER(lty)[i % nlty];
	else
	    dd->gp.lty = dd->dp.lty;
	if (nlwd && REAL(lwd)[i % nlwd] != NA_REAL)
	    dd->gp.lwd = REAL(lwd)[i % nlwd];
	else
	    dd->gp.lwd = dd->dp.lwd;
	x0 = xl[i%nxl];
	y0 = yb[i%nyb];
	x1 = xr[i%nxr];
	y1 = yt[i%nyt];
	GConvert(&x0, &y0, USER, DEVICE, dd);

		  INTEGER(border)[i % nborder], dd);
    }
    GMode(0, dd);
 
    GRestorePars(dd);
    UNPROTECT(4);
    /* NOTE: only record operation if no "error"  */
    /* NOTE: on replay, call == R_NilValue */
    if (call != R_NilValue)
	recordGraphicOperation(op, originalArgs, dd);
    return R_NilValue;

    args = CDR(args);
 
    if ((v = CAR(args)) != R_NilValue)
	CAR(args) = v = coerceVector(v, REALSXP);
    args = CDR(args);
 
    if ((untf = CAR(args)) != R_NilValue)
	CAR(args) = untf = coerceVector(untf, LGLSXP);
    args = CDR(args);
 
 

Rev 7002	Rev 7133
Line 28...	Line 28...
28	`#include "Graphics.h"`	28	`#include "Graphics.h"`
29	`#include "Print.h"`	29	`#include "Print.h"`
30		30
31	`void NewFrameConfirm()`	31	`void NewFrameConfirm()`
32	`{`	32	`{`
33	`char buf[16];`	33	`unsigned char buf[16];`
34	`R_ReadConsole("Hit <Return> to see next plot: ", buf, 16, 0);`	34	`R_ReadConsole("Hit <Return> to see next plot: ", buf, 16, 0);`
35	`}`	35	`}`
36		36
37	`/* Remember: +1 and/or -1 because C arrays are */`	37	`/* Remember: +1 and/or -1 because C arrays are */`
38	`/* zero-based and R-vectors are one-based. */`	38	`/* zero-based and R-vectors are one-based. */`
Line 227...	Line 227...
227	`}`	227	`}`
228	`else if (isInteger(font) \|\| isLogical(font)) {`	228	`else if (isInteger(font) \|\| isLogical(font)) {`
229	`ans = allocVector(INTSXP, n);`	229	`ans = allocVector(INTSXP, n);`
230	`for (i = 0; i < n; i++) {`	230	`for (i = 0; i < n; i++) {`
231	`k = INTEGER(font)[i];`	231	`k = INTEGER(font)[i];`
-		232	`#ifndef Win32`
232	`if (k < 1 \|\| k > 4) k = NA_INTEGER;`	233	`if (k < 1 \|\| k > 4) k = NA_INTEGER;`
-		234	`#else`
-		235	`if (k < 1 \|\| k > 32) k = NA_INTEGER;`
-		236	`#endif`
233	`INTEGER(ans)[i] = k;`	237	`INTEGER(ans)[i] = k;`
234	`}`	238	`}`
235	`}`	239	`}`
236	`else if (isReal(font)) {`	240	`else if (isReal(font)) {`
237	`ans = allocVector(INTSXP, n);`	241	`ans = allocVector(INTSXP, n);`
238	`for (i = 0; i < n; i++) {`	242	`for (i = 0; i < n; i++) {`
239	`k = REAL(font)[i];`	243	`k = REAL(font)[i];`
-		244	`#ifndef Win32`
240	`if (k < 1 \|\| k > 4) k = NA_INTEGER;`	245	`if (k < 1 \|\| k > 4) k = NA_INTEGER;`
-		246	`#else`
-		247	`if (k < 1 \|\| k > 32) k = NA_INTEGER;`
-		248	`#endif`
241	`INTEGER(ans)[i] = k;`	249	`INTEGER(ans)[i] = k;`
242	`}`	250	`}`
243	`}`	251	`}`
244	`else error("invalid font specification");`	252	`else error("invalid font specification");`
245	`return ans;`	253	`return ans;`
Line 1022...	Line 1030...
1022	`* plot points or lines of various types`	1030	`* plot points or lines of various types`
1023	`*/`	1031	`*/`
1024	`SEXP sxy, sx, sy, pch, cex, col, bg, lty;`	1032	`SEXP sxy, sx, sy, pch, cex, col, bg, lty;`
1025	`double x, y, xold, yold, xx, yy, thiscex;`	1033	`double x, y, xold, yold, xx, yy, thiscex;`
1026	`int i, n, npch, ncex, ncol, nbg, nlty, type=0, start=0, thispch, thiscol;`	1034	`int i, n, npch, ncex, ncol, nbg, nlty, type=0, start=0, thispch, thiscol;`
1027		1035
1028	`SEXP originalArgs = args;`	1036	`SEXP originalArgs = args;`
1029	`DevDesc *dd = CurrentDevice();`	1037	`DevDesc *dd = CurrentDevice();`
1030		1038
1031	`/* Basic Checks */`	1039	`/* Basic Checks */`
1032	`GCheckState(dd);`	1040	`GCheckState(dd);`
Line 1069...	Line 1077...
1069		1077
1070	`/* Default col was NA_INTEGER (0x80000000) which was interpreted`	1078	`/* Default col was NA_INTEGER (0x80000000) which was interpreted`
1071	`as zero (black) or "don't draw" depending on line/rect/circle`	1079	`as zero (black) or "don't draw" depending on line/rect/circle`
1072	`situation. Now we set the default to zero and don't plot at all`	1080	`situation. Now we set the default to zero and don't plot at all`
1073	`if col==NA.`	1081	`if col==NA.`
1074		1082
1075	`FIXME: bg needs similar change, but that requires changes to`	1083	`FIXME: bg needs similar change, but that requires changes to`
1076	`the specific drivers. */`	1084	`the specific drivers. */`
1077		1085
1078	`PROTECT(col = FixupCol(CAR(args), 0)); args = CDR(args);`	1086	`PROTECT(col = FixupCol(CAR(args), 0)); args = CDR(args);`
1079	`ncol = LENGTH(col);`	1087	`ncol = LENGTH(col);`
1080		1088
1081	`PROTECT(bg = FixupCol(CAR(args), NA_INTEGER)); args = CDR(args);`	1089	`PROTECT(bg = FixupCol(CAR(args), NA_INTEGER)); args = CDR(args);`
1082	`nbg = LENGTH(bg);`	1090	`nbg = LENGTH(bg);`
1083		1091
Line 1212...	Line 1220...
1212	`for (i = 0; i < n; i++) {`	1220	`for (i = 0; i < n; i++) {`
1213	`xx = x[i];`	1221	`xx = x[i];`
1214	`yy = y[i];`	1222	`yy = y[i];`
1215	`GConvert(&xx, &yy, USER, DEVICE, dd);`	1223	`GConvert(&xx, &yy, USER, DEVICE, dd);`
1216	`if (R_FINITE(xx) && R_FINITE(yy)) {`	1224	`if (R_FINITE(xx) && R_FINITE(yy)) {`
1217	`if (R_FINITE(thiscex = REAL(cex)[i % ncex])`	1225	`if (R_FINITE(thiscex = REAL(cex)[i % ncex])`
1218	`&& (thispch = INTEGER(pch)[i % npch]) != NA_INTEGER`	1226	`&& (thispch = INTEGER(pch)[i % npch]) != NA_INTEGER`
1219	`&& (thiscol = INTEGER(col)[i % ncol]) != NA_INTEGER)`	1227	`&& (thiscol = INTEGER(col)[i % ncol]) != NA_INTEGER)`
1220	`{`	1228	`{`
1221	`dd->gp.cex = thiscex * dd->gp.cexbase;`	1229	`dd->gp.cex = thiscex * dd->gp.cexbase;`
1222	`dd->gp.col = thiscol;`	1230	`dd->gp.col = thiscol;`
Line 1268...	Line 1276...
1268	`}`	1276	`}`
1269		1277
1270		1278
1271	`SEXP do_segments(SEXP call, SEXP op, SEXP args, SEXP env)`	1279	`SEXP do_segments(SEXP call, SEXP op, SEXP args, SEXP env)`
1272	`{`	1280	`{`
1273	`/* segments(x0, y0, x1, y1, col, lty, lwd, xpd) */`	1281	`/* segments(x0, y0, x1, y1, col, lty, lwd, ...) */`
1274	`SEXP sx0, sx1, sy0, sy1, col, lty, lwd;`	1282	`SEXP sx0, sx1, sy0, sy1, col, lty, lwd;`
1275	`double x0, x1, y0, y1;`	1283	`double x0, x1, y0, y1;`
1276	`double xx[2], yy[2];`	1284	`double xx[2], yy[2];`
1277	`int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;`	1285	`int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;`
1278	`SEXP originalArgs = args;`	1286	`SEXP originalArgs = args;`
Line 1336...	Line 1344...
1336	`}`	1344	`}`
1337		1345
1338		1346
1339	`SEXP do_rect(SEXP call, SEXP op, SEXP args, SEXP env)`	1347	`SEXP do_rect(SEXP call, SEXP op, SEXP args, SEXP env)`
1340	`{`	1348	`{`
1341	`/* rect(xl, yb, xr, yt, col, border, lty, xpd) */`	1349	`/* rect(xl, yb, xr, yt, col, border, lty, lwd, xpd) */`
1342	`SEXP sxl, sxr, syb, syt, col, lty, border;`	1350	`SEXP sxl, sxr, syb, syt, col, lty, lwd, border;`
1343	`double xl, xr, yb, yt, x0, y0, x1, y1;`	1351	`double xl, xr, yb, yt, x0, y0, x1, y1;`
1344	`int i, n, nxl, nxr, nyb, nyt;`	-
1345	`int ncol, nlty, nborder, xpd;`	1352	`int i, n, nxl, nxr, nyb, nyt, ncol, nlty, nlwd, nborder, xpd;`
1346	`SEXP originalArgs = args;`	1353	`SEXP originalArgs = args;`
1347	`DevDesc *dd = CurrentDevice();`	1354	`DevDesc *dd = CurrentDevice();`
1348		1355
1349	`if (length(args) < 4) errorcall(call, "too few arguments");`	1356	`if (length(args) < 4) errorcall(call, "too few arguments");`
1350	`GCheckState(dd);`	1357	`GCheckState(dd);`
Line 1362...	Line 1369...
1362	`nborder = LENGTH(border);`	1369	`nborder = LENGTH(border);`
1363		1370
1364	`PROTECT(lty = FixupLty(GetPar("lty", args), dd->gp.lty));`	1371	`PROTECT(lty = FixupLty(GetPar("lty", args), dd->gp.lty));`
1365	`nlty = length(lty);`	1372	`nlty = length(lty);`
1366		1373
-		1374	`PROTECT(lwd = FixupLwd(GetPar("lwd", args), dd->gp.lwd));`
-		1375	`nlwd = length(lwd);`
-		1376
1367	`xpd = asInteger(GetPar("xpd", args));`	1377	`xpd = asInteger(GetPar("xpd", args));`
1368		1378
1369	`GSavePars(dd);`	1379	`GSavePars(dd);`
1370		1380
1371	`if (xpd == NA_INTEGER)`	1381	`if (xpd == NA_INTEGER)`
Line 1379...	Line 1389...
1379	`yt = REAL(syt);`	1389	`yt = REAL(syt);`
1380		1390
1381	`GMode(1, dd);`	1391	`GMode(1, dd);`
1382	`for (i = 0; i < n; i++) {`	1392	`for (i = 0; i < n; i++) {`
1383	`if (nlty && INTEGER(lty)[i % nlty] != NA_INTEGER)`	1393	`if (nlty && INTEGER(lty)[i % nlty] != NA_INTEGER)`
1384	`dd->gp.lty = INTEGER(lty)[i % nlty];`	1394	`dd->gp.lty = INTEGER(lty)[i % nlty];`
-		1395	`else`
-		1396	`dd->gp.lty = dd->dp.lty;`
-		1397	`if (nlwd && REAL(lwd)[i % nlwd] != NA_REAL)`
-		1398	`dd->gp.lwd = REAL(lwd)[i % nlwd];`
1385	`else`	1399	`else`
1386	`dd->gp.lty = dd->dp.lty;`	1400	`dd->gp.lwd = dd->dp.lwd;`
1387	`x0 = xl[i%nxl];`	1401	`x0 = xl[i%nxl];`
1388	`y0 = yb[i%nyb];`	1402	`y0 = yb[i%nyb];`
1389	`x1 = xr[i%nxr];`	1403	`x1 = xr[i%nxr];`
1390	`y1 = yt[i%nyt];`	1404	`y1 = yt[i%nyt];`
1391	`GConvert(&x0, &y0, USER, DEVICE, dd);`	1405	`GConvert(&x0, &y0, USER, DEVICE, dd);`
Line 1395...	Line 1409...
1395	`INTEGER(border)[i % nborder], dd);`	1409	`INTEGER(border)[i % nborder], dd);`
1396	`}`	1410	`}`
1397	`GMode(0, dd);`	1411	`GMode(0, dd);`
1398		1412
1399	`GRestorePars(dd);`	1413	`GRestorePars(dd);`
1400	`UNPROTECT(3);`	1414	`UNPROTECT(4);`
1401	`/* NOTE: only record operation if no "error" */`	1415	`/* NOTE: only record operation if no "error" */`
1402	`/* NOTE: on replay, call == R_NilValue */`	1416	`/* NOTE: on replay, call == R_NilValue */`
1403	`if (call != R_NilValue)`	1417	`if (call != R_NilValue)`
1404	`recordGraphicOperation(op, originalArgs, dd);`	1418	`recordGraphicOperation(op, originalArgs, dd);`
1405	`return R_NilValue;`	1419	`return R_NilValue;`
Line 2100...	Line 2114...
2100	`args = CDR(args);`	2114	`args = CDR(args);`
2101		2115
2102	`if ((v = CAR(args)) != R_NilValue)`	2116	`if ((v = CAR(args)) != R_NilValue)`
2103	`CAR(args) = v = coerceVector(v, REALSXP);`	2117	`CAR(args) = v = coerceVector(v, REALSXP);`
2104	`args = CDR(args);`	2118	`args = CDR(args);`
2105		2119
2106	`if ((untf = CAR(args)) != R_NilValue)`	2120	`if ((untf = CAR(args)) != R_NilValue)`
2107	`CAR(args) = untf = coerceVector(untf, LGLSXP);`	2121	`CAR(args) = untf = coerceVector(untf, LGLSXP);`
2108	`args = CDR(args);`	2122	`args = CDR(args);`
2109		2123
2110		2124

The R Project SVN R

(root)/branches/R-exp-API/src/main/plot.c @ 28362 – Rev 7002 → 7133