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



			}
		    }
		    seglist = ctr_newseg(xx[0], yy[0], xx[1], yy[1], seglist);
		    seglist = ctr_newseg(xx[2], yy[2], xx[3], yy[3], seglist);
		}
		else error("k != 2 or 4");
	    }
	    ctr_SegDB[i + j * nx] = seglist;
	}
    }
 

    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 
    if (length(args) < 4)
	errorcall(call, "too few arguments");
 
    oargs = args;
 
    x = CAR(args);
    internalTypeCheck(call, x, REALSXP);

    nlty = length(lty);
 
    /* col, lwd and lty vectors here --- FIXME: "lwd" ???? */
 
    if (nx < 2 || ny < 2)
	errorcall(call, "insufficient x or y values");
 
    if (nrows(z) != nx || ncols(z) != ny)
	errorcall(call, "dimension mismatch");
 
    if (nc < 1)
	errorcall(call, "no contour values");
 
    for (i = 0; i < nx; i++) {
	if (!R_FINITE(REAL(x)[i]))
	    errorcall(call, "missing x values");
	if (i > 0 && REAL(x)[i] < REAL(x)[i - 1])
	    errorcall(call, "increasing x values expected");
    }
 
    for (i = 0; i < ny; i++) {
	if (!R_FINITE(REAL(y)[i]))
	    errorcall(call, "missing y values");
	if (i > 0 && REAL(y)[i] < REAL(y)[i - 1])
	    errorcall(call, "increasing y values expected");
    }
 
    ctr_xtol = 1e-3 * fabs(REAL(x)[nx-1]-REAL(x)[0]);
    ctr_ytol = 1e-3 * fabs(REAL(y)[ny-1]-REAL(y)[0]);
 
    for (i = 0; i < nc; i++)
	if (!R_FINITE(REAL(c)[i]))
	    errorcall(call, "illegal NA contour values");
 
    zmin = DBL_MAX;
    zmax = DBL_MIN;
    for (i = 0; i < nx * ny; i++)
	if (R_FINITE(REAL(z)[i])) {

	    if (zmin > REAL(z)[i]) zmin =  REAL(z)[i];
	}
 
    if (zmin >= zmax) {
	if (zmin == zmax)
	    warning("all z values are equal");
	else
	    warning("all z values are NA");
	return R_NilValue;
    }
 
    /* PREVIOUSLY: atom = DBL_EPSILON * (zmax - zmin); */
 

    if (call != R_NilValue)
	recordGraphicOperation(op, oargs, dd);
    return R_NilValue;
 
 badxy:
    errorcall(call, "invalid x / y limits");
 badlev:
    errorcall(call, "invalid contour levels");
    return R_NilValue;  /* never used; to keep -Wall happy */
}
 
 
	/*  I m a g e   R e n d e r i n g  */

    internalTypeCheck(call, szlim, REALSXP);
    if (length(szlim) != 2 ||
       !R_FINITE(REAL(szlim)[0]) ||
       !R_FINITE(REAL(szlim)[1]) ||
       REAL(szlim)[0] >= REAL(szlim)[1])
	errorcall(call, "invalid z limits");
    zmin = REAL(szlim)[0];
    zmax = REAL(szlim)[1];
    args = CDR(args);
 
    PROTECT(sc = FixupCol(CAR(args), NA_INTEGER));

    if (call != R_NilValue)
	recordGraphicOperation(op, oargs, dd);
    return R_NilValue;
 
  badxy:
    errorcall(call, "invalid x / y limits");
    return R_NilValue;/* never used; to keep -Wall happy */
}
 
	/*  P e r s p e c t i v e   S u r f a c e   P l o t s  */
 

	if (R_FINITE(x[i])) {
	    if (x[i] < xmin) xmin = x[i];
	    if (x[i] > xmax) xmax = x[i];
	}
    if (xmin < min || xmax > max)
	errorcall(gcall, "coordinates outsize specified range");
}
#endif
 
static void PerspWindow(double *xlim, double *ylim, double *zlim, DevDesc *dd)
{

    double expand, xc, yc, zc, xs, ys, zs;
    int i, j, scale, ncol, dobox;
    DevDesc *dd;
 
    if (length(args) < 18)
	errorcall(call, "too few parameters");
    gcall = call;
    originalArgs = args;
 
    PROTECT(x = coerceVector(CAR(args), REALSXP));
    if (length(x) < 2) errorcall(call, "invalid x argument");
    args = CDR(args);
 
    PROTECT(y = coerceVector(CAR(args), REALSXP));
    if (length(y) < 2) errorcall(call, "invalid y argument");
    args = CDR(args);
 
    PROTECT(z = coerceVector(CAR(args), REALSXP));
    if (!isMatrix(z) || nrows(z) != length(x) || ncols(z) != length(y))
	errorcall(call, "invalid z argument");
    args = CDR(args);
 
    PROTECT(xlim = coerceVector(CAR(args), REALSXP));
    if (length(xlim) != 2) errorcall(call, "invalid xlim argument");
    args = CDR(args);
 
    PROTECT(ylim = coerceVector(CAR(args), REALSXP));
    if (length(ylim) != 2) errorcall(call, "invalid ylim argument");
    args = CDR(args);
 
    PROTECT(zlim = coerceVector(CAR(args), REALSXP));
    if (length(zlim) != 2) errorcall(call, "invalid zlim argument");
    args = CDR(args);
 
    /* Checks on x/y/z Limits */
 
    if (!LimitCheck(REAL(xlim), &xc, &xs))
	errorcall(call, "invalid x limits");
    if (!LimitCheck(REAL(ylim), &yc, &ys))
	errorcall(call, "invalid y limits");
    if (!LimitCheck(REAL(zlim), &zc, &zs))
	errorcall(call, "invalid z limits");
 
    theta = asReal(CAR(args));
    args = CDR(args);
 
    phi = asReal(CAR(args));

 
    /* Parameter Checks */
 
    if (!R_FINITE(theta) || !R_FINITE(phi) || !R_FINITE(r) || !R_FINITE(d) ||
	d < 0 || r < 0)
	errorcall(call, "invalid viewing parameters");
    if (!R_FINITE(expand) || expand < 0)
	errorcall(call, "invalid expand value");
    if (scale == NA_LOGICAL)
	scale = 0;
 
    dd = GNewPlot(call != R_NilValue, NA_LOGICAL);
 
    PROTECT(col = FixupCol(col, dd->gp.bg));
    ncol = LENGTH(col);
    if (ncol < 1) errorcall(call, "invalid col specification");
    PROTECT(border = FixupCol(border, dd->gp.fg));
    if (length(border) < 1) errorcall(call, "invalid border specification");
 
    GSetState(1, dd);
    GSavePars(dd);
    ProcessInlinePars(args, dd);
    if (length(border) > 1)

Rev 5513	Rev 5731
Line 313...	Line 313...
313	`}`	313	`}`
314	`}`	314	`}`
315	`seglist = ctr_newseg(xx[0], yy[0], xx[1], yy[1], seglist);`	315	`seglist = ctr_newseg(xx[0], yy[0], xx[1], yy[1], seglist);`
316	`seglist = ctr_newseg(xx[2], yy[2], xx[3], yy[3], seglist);`	316	`seglist = ctr_newseg(xx[2], yy[2], xx[3], yy[3], seglist);`
317	`}`	317	`}`
318	`else error("k != 2 or 4\n");`	318	`else error("k != 2 or 4");`
319	`}`	319	`}`
320	`ctr_SegDB[i + j * nx] = seglist;`	320	`ctr_SegDB[i + j * nx] = seglist;`
321	`}`	321	`}`
322	`}`	322	`}`
323		323
Line 408...	Line 408...
408	`DevDesc *dd = CurrentDevice();`	408	`DevDesc *dd = CurrentDevice();`
409		409
410	`GCheckState(dd);`	410	`GCheckState(dd);`
411		411
412	`if (length(args) < 4)`	412	`if (length(args) < 4)`
413	`errorcall(call, "too few arguments\n");`	413	`errorcall(call, "too few arguments");`
414		414
415	`oargs = args;`	415	`oargs = args;`
416		416
417	`x = CAR(args);`	417	`x = CAR(args);`
418	`internalTypeCheck(call, x, REALSXP);`	418	`internalTypeCheck(call, x, REALSXP);`
Line 440...	Line 440...
440	`nlty = length(lty);`	440	`nlty = length(lty);`
441		441
442	`/* col, lwd and lty vectors here --- FIXME: "lwd" ???? */`	442	`/* col, lwd and lty vectors here --- FIXME: "lwd" ???? */`
443		443
444	`if (nx < 2 \|\| ny < 2)`	444	`if (nx < 2 \|\| ny < 2)`
445	`errorcall(call, "insufficient x or y values\n");`	445	`errorcall(call, "insufficient x or y values");`
446		446
447	`if (nrows(z) != nx \|\| ncols(z) != ny)`	447	`if (nrows(z) != nx \|\| ncols(z) != ny)`
448	`errorcall(call, "dimension mismatch\n");`	448	`errorcall(call, "dimension mismatch");`
449		449
450	`if (nc < 1)`	450	`if (nc < 1)`
451	`errorcall(call, "no contour values\n");`	451	`errorcall(call, "no contour values");`
452		452
453	`for (i = 0; i < nx; i++) {`	453	`for (i = 0; i < nx; i++) {`
454	`if (!R_FINITE(REAL(x)[i]))`	454	`if (!R_FINITE(REAL(x)[i]))`
455	`errorcall(call, "missing x values\n");`	455	`errorcall(call, "missing x values");`
456	`if (i > 0 && REAL(x)[i] < REAL(x)[i - 1])`	456	`if (i > 0 && REAL(x)[i] < REAL(x)[i - 1])`
457	`errorcall(call, "increasing x values expected\n");`	457	`errorcall(call, "increasing x values expected");`
458	`}`	458	`}`
459		459
460	`for (i = 0; i < ny; i++) {`	460	`for (i = 0; i < ny; i++) {`
461	`if (!R_FINITE(REAL(y)[i]))`	461	`if (!R_FINITE(REAL(y)[i]))`
462	`errorcall(call, "missing y values\n");`	462	`errorcall(call, "missing y values");`
463	`if (i > 0 && REAL(y)[i] < REAL(y)[i - 1])`	463	`if (i > 0 && REAL(y)[i] < REAL(y)[i - 1])`
464	`errorcall(call, "increasing y values expected\n");`	464	`errorcall(call, "increasing y values expected");`
465	`}`	465	`}`
466		466
467	`ctr_xtol = 1e-3 * fabs(REAL(x)[nx-1]-REAL(x)[0]);`	467	`ctr_xtol = 1e-3 * fabs(REAL(x)[nx-1]-REAL(x)[0]);`
468	`ctr_ytol = 1e-3 * fabs(REAL(y)[ny-1]-REAL(y)[0]);`	468	`ctr_ytol = 1e-3 * fabs(REAL(y)[ny-1]-REAL(y)[0]);`
469		469
470	`for (i = 0; i < nc; i++)`	470	`for (i = 0; i < nc; i++)`
471	`if (!R_FINITE(REAL(c)[i]))`	471	`if (!R_FINITE(REAL(c)[i]))`
472	`errorcall(call, "illegal NA contour values\n");`	472	`errorcall(call, "illegal NA contour values");`
473		473
474	`zmin = DBL_MAX;`	474	`zmin = DBL_MAX;`
475	`zmax = DBL_MIN;`	475	`zmax = DBL_MIN;`
476	`for (i = 0; i < nx * ny; i++)`	476	`for (i = 0; i < nx * ny; i++)`
477	`if (R_FINITE(REAL(z)[i])) {`	477	`if (R_FINITE(REAL(z)[i])) {`
Line 479...	Line 479...
479	`if (zmin > REAL(z)[i]) zmin = REAL(z)[i];`	479	`if (zmin > REAL(z)[i]) zmin = REAL(z)[i];`
480	`}`	480	`}`
481		481
482	`if (zmin >= zmax) {`	482	`if (zmin >= zmax) {`
483	`if (zmin == zmax)`	483	`if (zmin == zmax)`
484	`warning("all z values are equal\n");`	484	`warning("all z values are equal");`
485	`else`	485	`else`
486	`warning("all z values are NA\n");`	486	`warning("all z values are NA");`
487	`return R_NilValue;`	487	`return R_NilValue;`
488	`}`	488	`}`
489		489
490	`/* PREVIOUSLY: atom = DBL_EPSILON * (zmax - zmin); */`	490	`/* PREVIOUSLY: atom = DBL_EPSILON * (zmax - zmin); */`
491		491
Line 740...	Line 740...
740	`if (call != R_NilValue)`	740	`if (call != R_NilValue)`
741	`recordGraphicOperation(op, oargs, dd);`	741	`recordGraphicOperation(op, oargs, dd);`
742	`return R_NilValue;`	742	`return R_NilValue;`
743		743
744	`badxy:`	744	`badxy:`
745	`errorcall(call, "invalid x / y limits\n");`	745	`errorcall(call, "invalid x / y limits");`
746	`badlev:`	746	`badlev:`
747	`errorcall(call, "invalid contour levels\n");`	747	`errorcall(call, "invalid contour levels");`
748	`return R_NilValue; /* never used; to keep -Wall happy */`	748	`return R_NilValue; /* never used; to keep -Wall happy */`
749	`}`	749	`}`
750		750
751		751
752	`/* I m a g e R e n d e r i n g */`	752	`/* I m a g e R e n d e r i n g */`
Line 785...	Line 785...
785	`internalTypeCheck(call, szlim, REALSXP);`	785	`internalTypeCheck(call, szlim, REALSXP);`
786	`if (length(szlim) != 2 \|\|`	786	`if (length(szlim) != 2 \|\|`
787	`!R_FINITE(REAL(szlim)[0]) \|\|`	787	`!R_FINITE(REAL(szlim)[0]) \|\|`
788	`!R_FINITE(REAL(szlim)[1]) \|\|`	788	`!R_FINITE(REAL(szlim)[1]) \|\|`
789	`REAL(szlim)[0] >= REAL(szlim)[1])`	789	`REAL(szlim)[0] >= REAL(szlim)[1])`
790	`errorcall(call, "invalid z limits\n");`	790	`errorcall(call, "invalid z limits");`
791	`zmin = REAL(szlim)[0];`	791	`zmin = REAL(szlim)[0];`
792	`zmax = REAL(szlim)[1];`	792	`zmax = REAL(szlim)[1];`
793	`args = CDR(args);`	793	`args = CDR(args);`
794		794
795	`PROTECT(sc = FixupCol(CAR(args), NA_INTEGER));`	795	`PROTECT(sc = FixupCol(CAR(args), NA_INTEGER));`
Line 856...	Line 856...
856	`if (call != R_NilValue)`	856	`if (call != R_NilValue)`
857	`recordGraphicOperation(op, oargs, dd);`	857	`recordGraphicOperation(op, oargs, dd);`
858	`return R_NilValue;`	858	`return R_NilValue;`
859		859
860	`badxy:`	860	`badxy:`
861	`errorcall(call, "invalid x / y limits\n");`	861	`errorcall(call, "invalid x / y limits");`
862	`return R_NilValue;/* never used; to keep -Wall happy */`	862	`return R_NilValue;/* never used; to keep -Wall happy */`
863	`}`	863	`}`
864		864
865	`/* P e r s p e c t i v e S u r f a c e P l o t s */`	865	`/* P e r s p e c t i v e S u r f a c e P l o t s */`
866		866
Line 1199...	Line 1199...
1199	`if (R_FINITE(x[i])) {`	1199	`if (R_FINITE(x[i])) {`
1200	`if (x[i] < xmin) xmin = x[i];`	1200	`if (x[i] < xmin) xmin = x[i];`
1201	`if (x[i] > xmax) xmax = x[i];`	1201	`if (x[i] > xmax) xmax = x[i];`
1202	`}`	1202	`}`
1203	`if (xmin < min \|\| xmax > max)`	1203	`if (xmin < min \|\| xmax > max)`
1204	`errorcall(gcall, "coordinates outsize specified range\n");`	1204	`errorcall(gcall, "coordinates outsize specified range");`
1205	`}`	1205	`}`
1206	`#endif`	1206	`#endif`
1207		1207
1208	`static void PerspWindow(double xlim, double ylim, double zlim, DevDesc dd)`	1208	`static void PerspWindow(double xlim, double ylim, double zlim, DevDesc dd)`
1209	`{`	1209	`{`
Line 1373...	Line 1373...
1373	`double expand, xc, yc, zc, xs, ys, zs;`	1373	`double expand, xc, yc, zc, xs, ys, zs;`
1374	`int i, j, scale, ncol, dobox;`	1374	`int i, j, scale, ncol, dobox;`
1375	`DevDesc *dd;`	1375	`DevDesc *dd;`
1376		1376
1377	`if (length(args) < 18)`	1377	`if (length(args) < 18)`
1378	`errorcall(call, "too few parameters\n");`	1378	`errorcall(call, "too few parameters");`
1379	`gcall = call;`	1379	`gcall = call;`
1380	`originalArgs = args;`	1380	`originalArgs = args;`
1381		1381
1382	`PROTECT(x = coerceVector(CAR(args), REALSXP));`	1382	`PROTECT(x = coerceVector(CAR(args), REALSXP));`
1383	`if (length(x) < 2) errorcall(call, "invalid x argument\n");`	1383	`if (length(x) < 2) errorcall(call, "invalid x argument");`
1384	`args = CDR(args);`	1384	`args = CDR(args);`
1385		1385
1386	`PROTECT(y = coerceVector(CAR(args), REALSXP));`	1386	`PROTECT(y = coerceVector(CAR(args), REALSXP));`
1387	`if (length(y) < 2) errorcall(call, "invalid y argument\n");`	1387	`if (length(y) < 2) errorcall(call, "invalid y argument");`
1388	`args = CDR(args);`	1388	`args = CDR(args);`
1389		1389
1390	`PROTECT(z = coerceVector(CAR(args), REALSXP));`	1390	`PROTECT(z = coerceVector(CAR(args), REALSXP));`
1391	`if (!isMatrix(z) \|\| nrows(z) != length(x) \|\| ncols(z) != length(y))`	1391	`if (!isMatrix(z) \|\| nrows(z) != length(x) \|\| ncols(z) != length(y))`
1392	`errorcall(call, "invalid z argument\n");`	1392	`errorcall(call, "invalid z argument");`
1393	`args = CDR(args);`	1393	`args = CDR(args);`
1394		1394
1395	`PROTECT(xlim = coerceVector(CAR(args), REALSXP));`	1395	`PROTECT(xlim = coerceVector(CAR(args), REALSXP));`
1396	`if (length(xlim) != 2) errorcall(call, "invalid xlim argument\n");`	1396	`if (length(xlim) != 2) errorcall(call, "invalid xlim argument");`
1397	`args = CDR(args);`	1397	`args = CDR(args);`
1398		1398
1399	`PROTECT(ylim = coerceVector(CAR(args), REALSXP));`	1399	`PROTECT(ylim = coerceVector(CAR(args), REALSXP));`
1400	`if (length(ylim) != 2) errorcall(call, "invalid ylim argument\n");`	1400	`if (length(ylim) != 2) errorcall(call, "invalid ylim argument");`
1401	`args = CDR(args);`	1401	`args = CDR(args);`
1402		1402
1403	`PROTECT(zlim = coerceVector(CAR(args), REALSXP));`	1403	`PROTECT(zlim = coerceVector(CAR(args), REALSXP));`
1404	`if (length(zlim) != 2) errorcall(call, "invalid zlim argument\n");`	1404	`if (length(zlim) != 2) errorcall(call, "invalid zlim argument");`
1405	`args = CDR(args);`	1405	`args = CDR(args);`
1406		1406
1407	`/* Checks on x/y/z Limits */`	1407	`/* Checks on x/y/z Limits */`
1408		1408
1409	`if (!LimitCheck(REAL(xlim), &xc, &xs))`	1409	`if (!LimitCheck(REAL(xlim), &xc, &xs))`
1410	`errorcall(call, "invalid x limits\n");`	1410	`errorcall(call, "invalid x limits");`
1411	`if (!LimitCheck(REAL(ylim), &yc, &ys))`	1411	`if (!LimitCheck(REAL(ylim), &yc, &ys))`
1412	`errorcall(call, "invalid y limits\n");`	1412	`errorcall(call, "invalid y limits");`
1413	`if (!LimitCheck(REAL(zlim), &zc, &zs))`	1413	`if (!LimitCheck(REAL(zlim), &zc, &zs))`
1414	`errorcall(call, "invalid z limits\n");`	1414	`errorcall(call, "invalid z limits");`
1415		1415
1416	`theta = asReal(CAR(args));`	1416	`theta = asReal(CAR(args));`
1417	`args = CDR(args);`	1417	`args = CDR(args);`
1418		1418
1419	`phi = asReal(CAR(args));`	1419	`phi = asReal(CAR(args));`
Line 1465...	Line 1465...
1465		1465
1466	`/* Parameter Checks */`	1466	`/* Parameter Checks */`
1467		1467
1468	`if (!R_FINITE(theta) \|\| !R_FINITE(phi) \|\| !R_FINITE(r) \|\| !R_FINITE(d) \|\|`	1468	`if (!R_FINITE(theta) \|\| !R_FINITE(phi) \|\| !R_FINITE(r) \|\| !R_FINITE(d) \|\|`
1469	`d < 0 \|\| r < 0)`	1469	`d < 0 \|\| r < 0)`
1470	`errorcall(call, "invalid viewing parameters\n");`	1470	`errorcall(call, "invalid viewing parameters");`
1471	`if (!R_FINITE(expand) \|\| expand < 0)`	1471	`if (!R_FINITE(expand) \|\| expand < 0)`
1472	`errorcall(call, "invalid expand value\n");`	1472	`errorcall(call, "invalid expand value");`
1473	`if (scale == NA_LOGICAL)`	1473	`if (scale == NA_LOGICAL)`
1474	`scale = 0;`	1474	`scale = 0;`
1475		1475
1476	`dd = GNewPlot(call != R_NilValue, NA_LOGICAL);`	1476	`dd = GNewPlot(call != R_NilValue, NA_LOGICAL);`
1477		1477
1478	`PROTECT(col = FixupCol(col, dd->gp.bg));`	1478	`PROTECT(col = FixupCol(col, dd->gp.bg));`
1479	`ncol = LENGTH(col);`	1479	`ncol = LENGTH(col);`
1480	`if (ncol < 1) errorcall(call, "invalid col specification\n");`	1480	`if (ncol < 1) errorcall(call, "invalid col specification");`
1481	`PROTECT(border = FixupCol(border, dd->gp.fg));`	1481	`PROTECT(border = FixupCol(border, dd->gp.fg));`
1482	`if (length(border) < 1) errorcall(call, "invalid border specification\n");`	1482	`if (length(border) < 1) errorcall(call, "invalid border specification");`
1483		1483
1484	`GSetState(1, dd);`	1484	`GSetState(1, dd);`
1485	`GSavePars(dd);`	1485	`GSavePars(dd);`
1486	`ProcessInlinePars(args, dd);`	1486	`ProcessInlinePars(args, dd);`
1487	`if (length(border) > 1)`	1487	`if (length(border) > 1)`

The R Project SVN R

(root)/branches/R-exp-API/src/main/plot3d.c @ 28362 – Rev 5513 → 5731