The R Project SVN – R – Diff – /trunk/src/main/plot3d.c



    drawLabels = (Rboolean)asLogical(CAR(args));
    args = CDR(args);
 
    method = asInteger(CAR(args)); args = CDR(args);
    if (method < 1 || method > 3)
	errorcall(call, _("invalid value for 'method'"));
 
    PROTECT(vfont = FixupVFont(CAR(args)));
    if (!isNull(vfont)) {
	vectorFonts = TRUE;
	typeface = INTEGER(vfont)[0];

    PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
    nlwd = length(lwd);
    args = CDR(args);
 
    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"));
    }
 
    for (i = 0; i < nc; i++)
	if (!R_FINITE(REAL(c)[i]))
	    errorcall(call, _("invalid NA contour values"));

    internalTypeCheck(call, sc, REALSXP);
    nc = length(sc);
    args = CDR(args);
 
    if (nx < 2 || ny < 2)
	errorcall(call, _("insufficient 'x' or 'y' values"));
 
    if (nrows(sz) != nx || ncols(sz) != ny)
	errorcall(call, _("dimension mismatch"));
 
    if (nc < 1)

	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));	args = CDR(args);
    r	= asReal(CAR(args));	args = CDR(args);
    d	= asReal(CAR(args));	args = CDR(args);

 
    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;
    if ((nTicks == NA_INTEGER) || (nTicks < 0))
	errorcall(call, _("invalid 'nticks' value"));
    if ((tickType == NA_INTEGER) || (tickType < 1) || (tickType > 2))
	errorcall(call, _("invalid 'ticktype' value"));
 
    dd = CurrentDevice();
 
    GNewPlot(GRecording(call, dd));
 
    PROTECT(col = FixupCol(col, Rf_gpptr(dd)->bg));
    ncol = LENGTH(col);
    if (ncol < 1) errorcall(call, _("invalid 'col' specification"));
    if(!R_OPAQUE(INTEGER(col)[0])) DoLighting = FALSE;
    PROTECT(border = FixupCol(border, Rf_gpptr(dd)->fg));
    if (length(border) < 1) errorcall(call, _("invalid 'border' specification"));
 
    GSetState(1, dd);
    GSavePars(dd);
    ProcessInlinePars(args, dd, call);
    if (length(border) > 1)

Rev 32871	Rev 33297
Line 1415...	Line 1415...
1415	`drawLabels = (Rboolean)asLogical(CAR(args));`	1415	`drawLabels = (Rboolean)asLogical(CAR(args));`
1416	`args = CDR(args);`	1416	`args = CDR(args);`
1417		1417
1418	`method = asInteger(CAR(args)); args = CDR(args);`	1418	`method = asInteger(CAR(args)); args = CDR(args);`
1419	`if (method < 1 \|\| method > 3)`	1419	`if (method < 1 \|\| method > 3)`
1420	`errorcall(call, _("invalid value for 'method\'"));`	1420	`errorcall(call, _("invalid value for 'method'"));`
1421		1421
1422	`PROTECT(vfont = FixupVFont(CAR(args)));`	1422	`PROTECT(vfont = FixupVFont(CAR(args)));`
1423	`if (!isNull(vfont)) {`	1423	`if (!isNull(vfont)) {`
1424	`vectorFonts = TRUE;`	1424	`vectorFonts = TRUE;`
1425	`typeface = INTEGER(vfont)[0];`	1425	`typeface = INTEGER(vfont)[0];`
Line 1439...	Line 1439...
1439	`PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));`	1439	`PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));`
1440	`nlwd = length(lwd);`	1440	`nlwd = length(lwd);`
1441	`args = CDR(args);`	1441	`args = CDR(args);`
1442		1442
1443	`if (nx < 2 \|\| ny < 2)`	1443	`if (nx < 2 \|\| ny < 2)`
1444	`errorcall(call, _("insufficient x or y values"));`	1444	`errorcall(call, _("insufficient 'x' or 'y' values"));`
1445		1445
1446	`if (nrows(z) != nx \|\| ncols(z) != ny)`	1446	`if (nrows(z) != nx \|\| ncols(z) != ny)`
1447	`errorcall(call, _("dimension mismatch"));`	1447	`errorcall(call, _("dimension mismatch"));`
1448		1448
1449	`if (nc < 1)`	1449	`if (nc < 1)`
1450	`errorcall(call, _("no contour values"));`	1450	`errorcall(call, _("no contour values"));`
1451		1451
1452	`for (i = 0; i < nx; i++) {`	1452	`for (i = 0; i < nx; i++) {`
1453	`if (!R_FINITE(REAL(x)[i]))`	1453	`if (!R_FINITE(REAL(x)[i]))`
1454	`errorcall(call, _("missing x values"));`	1454	`errorcall(call, _("missing 'x' values"));`
1455	`if (i > 0 && REAL(x)[i] < REAL(x)[i - 1])`	1455	`if (i > 0 && REAL(x)[i] < REAL(x)[i - 1])`
1456	`errorcall(call, _("increasing x values expected"));`	1456	`errorcall(call, _("increasing 'x' values expected"));`
1457	`}`	1457	`}`
1458		1458
1459	`for (i = 0; i < ny; i++) {`	1459	`for (i = 0; i < ny; i++) {`
1460	`if (!R_FINITE(REAL(y)[i]))`	1460	`if (!R_FINITE(REAL(y)[i]))`
1461	`errorcall(call, _("missing y values"));`	1461	`errorcall(call, _("missing 'y' values"));`
1462	`if (i > 0 && REAL(y)[i] < REAL(y)[i - 1])`	1462	`if (i > 0 && REAL(y)[i] < REAL(y)[i - 1])`
1463	`errorcall(call, _("increasing y values expected"));`	1463	`errorcall(call, _("increasing 'y' values expected"));`
1464	`}`	1464	`}`
1465		1465
1466	`for (i = 0; i < nc; i++)`	1466	`for (i = 0; i < nc; i++)`
1467	`if (!R_FINITE(REAL(c)[i]))`	1467	`if (!R_FINITE(REAL(c)[i]))`
1468	`errorcall(call, _("invalid NA contour values"));`	1468	`errorcall(call, _("invalid NA contour values"));`
Line 1691...	Line 1691...
1691	`internalTypeCheck(call, sc, REALSXP);`	1691	`internalTypeCheck(call, sc, REALSXP);`
1692	`nc = length(sc);`	1692	`nc = length(sc);`
1693	`args = CDR(args);`	1693	`args = CDR(args);`
1694		1694
1695	`if (nx < 2 \|\| ny < 2)`	1695	`if (nx < 2 \|\| ny < 2)`
1696	`errorcall(call, _("insufficient x or y values"));`	1696	`errorcall(call, _("insufficient 'x' or 'y' values"));`
1697		1697
1698	`if (nrows(sz) != nx \|\| ncols(sz) != ny)`	1698	`if (nrows(sz) != nx \|\| ncols(sz) != ny)`
1699	`errorcall(call, _("dimension mismatch"));`	1699	`errorcall(call, _("dimension mismatch"));`
1700		1700
1701	`if (nc < 1)`	1701	`if (nc < 1)`
Line 2472...	Line 2472...
2472	`errorcall(call, _("too few parameters"));`	2472	`errorcall(call, _("too few parameters"));`
2473	`gcall = call;`	2473	`gcall = call;`
2474	`originalArgs = args;`	2474	`originalArgs = args;`
2475		2475
2476	`PROTECT(x = coerceVector(CAR(args), REALSXP));`	2476	`PROTECT(x = coerceVector(CAR(args), REALSXP));`
2477	`if (length(x) < 2) errorcall(call, _("invalid x argument"));`	2477	`if (length(x) < 2) errorcall(call, _("invalid 'x' argument"));`
2478	`args = CDR(args);`	2478	`args = CDR(args);`
2479		2479
2480	`PROTECT(y = coerceVector(CAR(args), REALSXP));`	2480	`PROTECT(y = coerceVector(CAR(args), REALSXP));`
2481	`if (length(y) < 2) errorcall(call, _("invalid y argument"));`	2481	`if (length(y) < 2) errorcall(call, _("invalid 'y' argument"));`
2482	`args = CDR(args);`	2482	`args = CDR(args);`
2483		2483
2484	`PROTECT(z = coerceVector(CAR(args), REALSXP));`	2484	`PROTECT(z = coerceVector(CAR(args), REALSXP));`
2485	`if (!isMatrix(z) \|\| nrows(z) != length(x) \|\| ncols(z) != length(y))`	2485	`if (!isMatrix(z) \|\| nrows(z) != length(x) \|\| ncols(z) != length(y))`
2486	`errorcall(call, _("invalid z argument"));`	2486	`errorcall(call, _("invalid 'z' argument"));`
2487	`args = CDR(args);`	2487	`args = CDR(args);`
2488		2488
2489	`PROTECT(xlim = coerceVector(CAR(args), REALSXP));`	2489	`PROTECT(xlim = coerceVector(CAR(args), REALSXP));`
2490	`if (length(xlim) != 2) errorcall(call, _("invalid xlim argument"));`	2490	`if (length(xlim) != 2) errorcall(call, _("invalid 'xlim' argument"));`
2491	`args = CDR(args);`	2491	`args = CDR(args);`
2492		2492
2493	`PROTECT(ylim = coerceVector(CAR(args), REALSXP));`	2493	`PROTECT(ylim = coerceVector(CAR(args), REALSXP));`
2494	`if (length(ylim) != 2) errorcall(call, _("invalid ylim argument"));`	2494	`if (length(ylim) != 2) errorcall(call, _("invalid 'ylim' argument"));`
2495	`args = CDR(args);`	2495	`args = CDR(args);`
2496		2496
2497	`PROTECT(zlim = coerceVector(CAR(args), REALSXP));`	2497	`PROTECT(zlim = coerceVector(CAR(args), REALSXP));`
2498	`if (length(zlim) != 2) errorcall(call, _("invalid zlim argument"));`	2498	`if (length(zlim) != 2) errorcall(call, _("invalid 'zlim' argument"));`
2499	`args = CDR(args);`	2499	`args = CDR(args);`
2500		2500
2501	`/* Checks on x/y/z Limits */`	2501	`/* Checks on x/y/z Limits */`
2502		2502
2503	`if (!LimitCheck(REAL(xlim), &xc, &xs))`	2503	`if (!LimitCheck(REAL(xlim), &xc, &xs))`
2504	`errorcall(call, _("invalid x limits"));`	2504	`errorcall(call, _("invalid 'x' limits"));`
2505	`if (!LimitCheck(REAL(ylim), &yc, &ys))`	2505	`if (!LimitCheck(REAL(ylim), &yc, &ys))`
2506	`errorcall(call, _("invalid y limits"));`	2506	`errorcall(call, _("invalid 'y' limits"));`
2507	`if (!LimitCheck(REAL(zlim), &zc, &zs))`	2507	`if (!LimitCheck(REAL(zlim), &zc, &zs))`
2508	`errorcall(call, _("invalid z limits"));`	2508	`errorcall(call, _("invalid 'z' limits"));`
2509		2509
2510	`theta = asReal(CAR(args)); args = CDR(args);`	2510	`theta = asReal(CAR(args)); args = CDR(args);`
2511	`phi = asReal(CAR(args)); args = CDR(args);`	2511	`phi = asReal(CAR(args)); args = CDR(args);`
2512	`r = asReal(CAR(args)); args = CDR(args);`	2512	`r = asReal(CAR(args)); args = CDR(args);`
2513	`d = asReal(CAR(args)); args = CDR(args);`	2513	`d = asReal(CAR(args)); args = CDR(args);`
Line 2550...	Line 2550...
2550		2550
2551	`if (!R_FINITE(theta) \|\| !R_FINITE(phi) \|\| !R_FINITE(r) \|\| !R_FINITE(d) \|\|`	2551	`if (!R_FINITE(theta) \|\| !R_FINITE(phi) \|\| !R_FINITE(r) \|\| !R_FINITE(d) \|\|`
2552	`d < 0 \|\| r < 0)`	2552	`d < 0 \|\| r < 0)`
2553	`errorcall(call, _("invalid viewing parameters"));`	2553	`errorcall(call, _("invalid viewing parameters"));`
2554	`if (!R_FINITE(expand) \|\| expand < 0)`	2554	`if (!R_FINITE(expand) \|\| expand < 0)`
2555	`errorcall(call, _("invalid expand value"));`	2555	`errorcall(call, _("invalid 'expand' value"));`
2556	`if (scale == NA_LOGICAL)`	2556	`if (scale == NA_LOGICAL)`
2557	`scale = 0;`	2557	`scale = 0;`
2558	`if ((nTicks == NA_INTEGER) \|\| (nTicks < 0))`	2558	`if ((nTicks == NA_INTEGER) \|\| (nTicks < 0))`
2559	`errorcall(call, _("invalid nticks value"));`	2559	`errorcall(call, _("invalid 'nticks' value"));`
2560	`if ((tickType == NA_INTEGER) \|\| (tickType < 1) \|\| (tickType > 2))`	2560	`if ((tickType == NA_INTEGER) \|\| (tickType < 1) \|\| (tickType > 2))`
2561	`errorcall(call, _("invalid ticktype value"));`	2561	`errorcall(call, _("invalid 'ticktype' value"));`
2562		2562
2563	`dd = CurrentDevice();`	2563	`dd = CurrentDevice();`
2564		2564
2565	`GNewPlot(GRecording(call, dd));`	2565	`GNewPlot(GRecording(call, dd));`
2566		2566
2567	`PROTECT(col = FixupCol(col, Rf_gpptr(dd)->bg));`	2567	`PROTECT(col = FixupCol(col, Rf_gpptr(dd)->bg));`
2568	`ncol = LENGTH(col);`	2568	`ncol = LENGTH(col);`
2569	`if (ncol < 1) errorcall(call, _("invalid col specification"));`	2569	`if (ncol < 1) errorcall(call, _("invalid 'col' specification"));`
2570	`if(!R_OPAQUE(INTEGER(col)[0])) DoLighting = FALSE;`	2570	`if(!R_OPAQUE(INTEGER(col)[0])) DoLighting = FALSE;`
2571	`PROTECT(border = FixupCol(border, Rf_gpptr(dd)->fg));`	2571	`PROTECT(border = FixupCol(border, Rf_gpptr(dd)->fg));`
2572	`if (length(border) < 1) errorcall(call, _("invalid border specification"));`	2572	`if (length(border) < 1) errorcall(call, _("invalid 'border' specification"));`
2573		2573
2574	`GSetState(1, dd);`	2574	`GSetState(1, dd);`
2575	`GSavePars(dd);`	2575	`GSavePars(dd);`
2576	`ProcessInlinePars(args, dd, call);`	2576	`ProcessInlinePars(args, dd, call);`
2577	`if (length(border) > 1)`	2577	`if (length(border) > 1)`

The R Project SVN R

(root)/trunk/src/main/plot3d.c – Rev 32871 → 33297