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



		while (s && ns < MAX_ns) {
		    ns++;
		    s = s->next;
		}
		if(ns == MAX_ns)
		    warning(_("contour(): circular/long seglist -- bug.report()!"));
 
		/* countour midpoint : use for labelling sometime (not yet!) */
		if (ns > 3) ns2 = ns/2; else ns2 = -1;
 
		/*

	    if (zmin > z[i]) zmin =  z[i];
	}
 
    if (zmin >= zmax) {
	if (zmin == zmax)
	    warning(_("all z values are equal"));
	else
	    warning(_("all z values are NA"));
	return R_NilValue;
    }
    /* change to 1e-3, reconsidered because of PR#897
     * but 1e-7, and even  2*DBL_EPSILON do not prevent inf.loop in contour().
     * maybe something like   16 * DBL_EPSILON * (..).

		    SEXP labels, int cnum,
		    Rboolean drawLabels, int method,
		    Rboolean vectorFonts, int typeface, int fontindex,
		    double atom, DevDesc *dd)
{
/* draw a contour for one given contour level 'zc' */
 
    char *vmax;
 
    double xend, yend;
    int i, ii, j, jj, ns, ns2, dir;

	    while (s && ns < MAX_ns) {
		ns++;
		s = s->next;
	    }
	    if(ns == MAX_ns)
		warning(_("contour(): circular/long seglist -- bug.report()!"));
 
	    /* countour midpoint : use for labelling sometime (not yet!) */
	    if (ns > 3) ns2 = ns/2; else ns2 = -1;
 
	    vmax = vmaxget();

    SEXP result = R_NilValue;
 
    GCheckState(dd);
 
    if (length(args) < 4)
	errorcall(call, _("too few arguments"));
 
    oargs = args;
 
    x = CAR(args);
    internalTypeCheck(call, x, REALSXP);

    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"));
 
    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;
    }
 
    /* change to 1e-3, reconsidered because of PR#897
     * but 1e-7, and even  2*DBL_EPSILON do not prevent inf.loop in contour().

    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, _("no contour values"));
 
    PROTECT(scol = FixupCol(CAR(args), R_TRANWHITE));
    ncol = length(scol);
 
    /* Shorthand Pointers */

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

    if (GRecording(call, dd))
	recordGraphicOperation(op, oargs, dd);
    return R_NilValue;
 
  badxy:
    errorcall(call, _("invalid x / y values or 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)
{

	yAxis = 1;
    } else if (lowest(v3[1]/v3[3], v1[1]/v1[3], v2[1]/v2[3], v0[1]/v0[3])) {
	xAxis = 2;
	yAxis = 3;
    } else
	warning(_("Axis orientation not calculated"));
    PerspAxis(x, y, z, xAxis, 0, nTicks, tickType, xlab, dd);
    PerspAxis(x, y, z, yAxis, 1, nTicks, tickType, ylab, dd);
    /* Figure out which Z axis to draw */
    if (lowest(v0[0]/v0[3], v1[0]/v1[3], v2[0]/v2[3], v3[0]/v3[3])) {
	zAxis = 4;

    } else if (lowest(v2[0]/v2[3], v1[0]/v1[3], v0[0]/v0[3], v3[0]/v3[3])) {
	zAxis = 6;
    } else if (lowest(v3[0]/v3[3], v1[0]/v1[3], v2[0]/v2[3], v0[0]/v0[3])) {
	zAxis = 7;
    } else
	warning(_("Axis orientation not calculated"));
    PerspAxis(x, y, z, zAxis, 2, nTicks, tickType, zlab, dd);
 
    Rf_gpptr(dd)->xpd = xpdsave;
}
 

    double expand, xc, yc, zc, xs, ys, zs;
    int i, j, scale, ncol, dobox, doaxes, nTicks, tickType;
    DevDesc *dd;
 
    if (length(args) < 24)
	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);

    tickType = asInteger(CAR(args)); args = CDR(args);
    xlab = CAR(args); args = CDR(args);
    ylab = CAR(args); args = CDR(args);
    zlab = CAR(args); args = CDR(args);
    if (!isString(xlab) || length(xlab) < 1)
	error(_("'xlab' must be a character vector of length 1"));
    if (!isString(ylab) || length(ylab) < 1)
	error(_("'ylab' must be a character vector of length 1"));
    if (!isString(zlab) || length(zlab) < 1)
	error(_("'zlab' must be a character vector of length 1"));
 
    if (R_FINITE(Shade) && Shade <= 0) Shade = 1;
    if (R_FINITE(ltheta) && R_FINITE(lphi) && R_FINITE(Shade))
	DoLighting = TRUE;
    else

 
    /* 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;
    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 32380	Rev 32871
Line 719...	Line 719...
719	`while (s && ns < MAX_ns) {`	719	`while (s && ns < MAX_ns) {`
720	`ns++;`	720	`ns++;`
721	`s = s->next;`	721	`s = s->next;`
722	`}`	722	`}`
723	`if(ns == MAX_ns)`	723	`if(ns == MAX_ns)`
724	`warning("contour(): circular/long seglist -- bug.report()!");`	724	`warning(_("contour(): circular/long seglist -- bug.report()!"));`
725		725
726	`/* countour midpoint : use for labelling sometime (not yet!) */`	726	`/* countour midpoint : use for labelling sometime (not yet!) */`
727	`if (ns > 3) ns2 = ns/2; else ns2 = -1;`	727	`if (ns > 3) ns2 = ns/2; else ns2 = -1;`
728		728
729	`/*`	729	`/*`
Line 801...	Line 801...
801	`if (zmin > z[i]) zmin = z[i];`	801	`if (zmin > z[i]) zmin = z[i];`
802	`}`	802	`}`
803		803
804	`if (zmin >= zmax) {`	804	`if (zmin >= zmax) {`
805	`if (zmin == zmax)`	805	`if (zmin == zmax)`
806	`warning("all z values are equal");`	806	`warning(_("all z values are equal"));`
807	`else`	807	`else`
808	`warning("all z values are NA");`	808	`warning(_("all z values are NA"));`
809	`return R_NilValue;`	809	`return R_NilValue;`
810	`}`	810	`}`
811	`/* change to 1e-3, reconsidered because of PR#897`	811	`/* change to 1e-3, reconsidered because of PR#897`
812	`* but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().`	812	`* but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().`
813	`* maybe something like 16 * DBL_EPSILON * (..).`	813	`* maybe something like 16 * DBL_EPSILON * (..).`
Line 925...	Line 925...
925	`SEXP labels, int cnum,`	925	`SEXP labels, int cnum,`
926	`Rboolean drawLabels, int method,`	926	`Rboolean drawLabels, int method,`
927	`Rboolean vectorFonts, int typeface, int fontindex,`	927	`Rboolean vectorFonts, int typeface, int fontindex,`
928	`double atom, DevDesc *dd)`	928	`double atom, DevDesc *dd)`
929	`{`	929	`{`
930	/* draw a contour for one given contour level `zc' */	930	`/* draw a contour for one given contour level 'zc' */`
931		931
932	`char *vmax;`	932	`char *vmax;`
933		933
934	`double xend, yend;`	934	`double xend, yend;`
935	`int i, ii, j, jj, ns, ns2, dir;`	935	`int i, ii, j, jj, ns, ns2, dir;`
Line 1014...	Line 1014...
1014	`while (s && ns < MAX_ns) {`	1014	`while (s && ns < MAX_ns) {`
1015	`ns++;`	1015	`ns++;`
1016	`s = s->next;`	1016	`s = s->next;`
1017	`}`	1017	`}`
1018	`if(ns == MAX_ns)`	1018	`if(ns == MAX_ns)`
1019	`warning("contour(): circular/long seglist -- bug.report()!");`	1019	`warning(_("contour(): circular/long seglist -- bug.report()!"));`
1020		1020
1021	`/* countour midpoint : use for labelling sometime (not yet!) */`	1021	`/* countour midpoint : use for labelling sometime (not yet!) */`
1022	`if (ns > 3) ns2 = ns/2; else ns2 = -1;`	1022	`if (ns > 3) ns2 = ns/2; else ns2 = -1;`
1023		1023
1024	`vmax = vmaxget();`	1024	`vmax = vmaxget();`
Line 1378...	Line 1378...
1378	`SEXP result = R_NilValue;`	1378	`SEXP result = R_NilValue;`
1379		1379
1380	`GCheckState(dd);`	1380	`GCheckState(dd);`
1381		1381
1382	`if (length(args) < 4)`	1382	`if (length(args) < 4)`
1383	`errorcall(call, "too few arguments");`	1383	`errorcall(call, _("too few arguments"));`
1384		1384
1385	`oargs = args;`	1385	`oargs = args;`
1386		1386
1387	`x = CAR(args);`	1387	`x = CAR(args);`
1388	`internalTypeCheck(call, x, REALSXP);`	1388	`internalTypeCheck(call, x, REALSXP);`
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, "illegal NA contour values");`	1468	`errorcall(call, _("invalid NA contour values"));`
1469		1469
1470	`zmin = DBL_MAX;`	1470	`zmin = DBL_MAX;`
1471	`zmax = DBL_MIN;`	1471	`zmax = DBL_MIN;`
1472	`for (i = 0; i < nx * ny; i++)`	1472	`for (i = 0; i < nx * ny; i++)`
1473	`if (R_FINITE(REAL(z)[i])) {`	1473	`if (R_FINITE(REAL(z)[i])) {`
Line 1475...	Line 1475...
1475	`if (zmin > REAL(z)[i]) zmin = REAL(z)[i];`	1475	`if (zmin > REAL(z)[i]) zmin = REAL(z)[i];`
1476	`}`	1476	`}`
1477		1477
1478	`if (zmin >= zmax) {`	1478	`if (zmin >= zmax) {`
1479	`if (zmin == zmax)`	1479	`if (zmin == zmax)`
1480	`warning("all z values are equal");`	1480	`warning(_("all z values are equal"));`
1481	`else`	1481	`else`
1482	`warning("all z values are NA");`	1482	`warning(_("all z values are NA"));`
1483	`return R_NilValue;`	1483	`return R_NilValue;`
1484	`}`	1484	`}`
1485		1485
1486	`/* change to 1e-3, reconsidered because of PR#897`	1486	`/* change to 1e-3, reconsidered because of PR#897`
1487	`* but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().`	1487	`* but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().`
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)`
1702	`errorcall(call, "no contour values");`	1702	`errorcall(call, _("no contour values"));`
1703		1703
1704	`PROTECT(scol = FixupCol(CAR(args), R_TRANWHITE));`	1704	`PROTECT(scol = FixupCol(CAR(args), R_TRANWHITE));`
1705	`ncol = length(scol);`	1705	`ncol = length(scol);`
1706		1706
1707	`/* Shorthand Pointers */`	1707	`/* Shorthand Pointers */`
Line 1762...	Line 1762...
1762	`if (GRecording(call, dd))`	1762	`if (GRecording(call, dd))`
1763	`recordGraphicOperation(op, oargs, dd);`	1763	`recordGraphicOperation(op, oargs, dd);`
1764	`return R_NilValue;`	1764	`return R_NilValue;`
1765		1765
1766	`badxy:`	1766	`badxy:`
1767	`errorcall(call, "invalid x / y values or limits");`	1767	`errorcall(call, _("invalid x / y values or limits"));`
1768	`badlev:`	1768	`badlev:`
1769	`errorcall(call, "invalid contour levels: must be strictly increasing");`	1769	`errorcall(call, _("invalid contour levels: must be strictly increasing"));`
1770	`return R_NilValue; /* never used; to keep -Wall happy */`	1770	`return R_NilValue; /* never used; to keep -Wall happy */`
1771	`}`	1771	`}`
1772		1772
1773		1773
1774	`/* I m a g e R e n d e r i n g */`	1774	`/* I m a g e R e n d e r i n g */`
Line 1847...	Line 1847...
1847	`if (GRecording(call, dd))`	1847	`if (GRecording(call, dd))`
1848	`recordGraphicOperation(op, oargs, dd);`	1848	`recordGraphicOperation(op, oargs, dd);`
1849	`return R_NilValue;`	1849	`return R_NilValue;`
1850		1850
1851	`badxy:`	1851	`badxy:`
1852	`errorcall(call, "invalid x / y values or limits");`	1852	`errorcall(call, _("invalid x / y values or limits"));`
1853	`return R_NilValue;/* never used; to keep -Wall happy */`	1853	`return R_NilValue;/* never used; to keep -Wall happy */`
1854	`}`	1854	`}`
1855		1855
1856	`/* P e r s p e c t i v e S u r f a c e P l o t s */`	1856	`/* P e r s p e c t i v e S u r f a c e P l o t s */`
1857		1857
Line 2018...	Line 2018...
2018	`if (R_FINITE(x[i])) {`	2018	`if (R_FINITE(x[i])) {`
2019	`if (x[i] < xmin) xmin = x[i];`	2019	`if (x[i] < xmin) xmin = x[i];`
2020	`if (x[i] > xmax) xmax = x[i];`	2020	`if (x[i] > xmax) xmax = x[i];`
2021	`}`	2021	`}`
2022	`if (xmin < min \|\| xmax > max)`	2022	`if (xmin < min \|\| xmax > max)`
2023	`errorcall(gcall, "coordinates outsize specified range");`	2023	`errorcall(gcall, _("coordinates outsize specified range"));`
2024	`}`	2024	`}`
2025	`#endif`	2025	`#endif`
2026		2026
2027	`static void PerspWindow(double xlim, double ylim, double zlim, DevDesc dd)`	2027	`static void PerspWindow(double xlim, double ylim, double zlim, DevDesc dd)`
2028	`{`	2028	`{`
Line 2436...	Line 2436...
2436	`yAxis = 1;`	2436	`yAxis = 1;`
2437	`} else if (lowest(v3[1]/v3[3], v1[1]/v1[3], v2[1]/v2[3], v0[1]/v0[3])) {`	2437	`} else if (lowest(v3[1]/v3[3], v1[1]/v1[3], v2[1]/v2[3], v0[1]/v0[3])) {`
2438	`xAxis = 2;`	2438	`xAxis = 2;`
2439	`yAxis = 3;`	2439	`yAxis = 3;`
2440	`} else`	2440	`} else`
2441	`warning("Axis orientation not calculated");`	2441	`warning(_("Axis orientation not calculated"));`
2442	`PerspAxis(x, y, z, xAxis, 0, nTicks, tickType, xlab, dd);`	2442	`PerspAxis(x, y, z, xAxis, 0, nTicks, tickType, xlab, dd);`
2443	`PerspAxis(x, y, z, yAxis, 1, nTicks, tickType, ylab, dd);`	2443	`PerspAxis(x, y, z, yAxis, 1, nTicks, tickType, ylab, dd);`
2444	`/* Figure out which Z axis to draw */`	2444	`/* Figure out which Z axis to draw */`
2445	`if (lowest(v0[0]/v0[3], v1[0]/v1[3], v2[0]/v2[3], v3[0]/v3[3])) {`	2445	`if (lowest(v0[0]/v0[3], v1[0]/v1[3], v2[0]/v2[3], v3[0]/v3[3])) {`
2446	`zAxis = 4;`	2446	`zAxis = 4;`
Line 2449...	Line 2449...
2449	`} else if (lowest(v2[0]/v2[3], v1[0]/v1[3], v0[0]/v0[3], v3[0]/v3[3])) {`	2449	`} else if (lowest(v2[0]/v2[3], v1[0]/v1[3], v0[0]/v0[3], v3[0]/v3[3])) {`
2450	`zAxis = 6;`	2450	`zAxis = 6;`
2451	`} else if (lowest(v3[0]/v3[3], v1[0]/v1[3], v2[0]/v2[3], v0[0]/v0[3])) {`	2451	`} else if (lowest(v3[0]/v3[3], v1[0]/v1[3], v2[0]/v2[3], v0[0]/v0[3])) {`
2452	`zAxis = 7;`	2452	`zAxis = 7;`
2453	`} else`	2453	`} else`
2454	`warning("Axes orientation not calculated");`	2454	`warning(_("Axis orientation not calculated"));`
2455	`PerspAxis(x, y, z, zAxis, 2, nTicks, tickType, zlab, dd);`	2455	`PerspAxis(x, y, z, zAxis, 2, nTicks, tickType, zlab, dd);`
2456		2456
2457	`Rf_gpptr(dd)->xpd = xpdsave;`	2457	`Rf_gpptr(dd)->xpd = xpdsave;`
2458	`}`	2458	`}`
2459		2459
Line 2467...	Line 2467...
2467	`double expand, xc, yc, zc, xs, ys, zs;`	2467	`double expand, xc, yc, zc, xs, ys, zs;`
2468	`int i, j, scale, ncol, dobox, doaxes, nTicks, tickType;`	2468	`int i, j, scale, ncol, dobox, doaxes, nTicks, tickType;`
2469	`DevDesc *dd;`	2469	`DevDesc *dd;`
2470		2470
2471	`if (length(args) < 24)`	2471	`if (length(args) < 24)`
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 2524...	Line 2524...
2524	`tickType = asInteger(CAR(args)); args = CDR(args);`	2524	`tickType = asInteger(CAR(args)); args = CDR(args);`
2525	`xlab = CAR(args); args = CDR(args);`	2525	`xlab = CAR(args); args = CDR(args);`
2526	`ylab = CAR(args); args = CDR(args);`	2526	`ylab = CAR(args); args = CDR(args);`
2527	`zlab = CAR(args); args = CDR(args);`	2527	`zlab = CAR(args); args = CDR(args);`
2528	`if (!isString(xlab) \|\| length(xlab) < 1)`	2528	`if (!isString(xlab) \|\| length(xlab) < 1)`
2529	error("`xlab' must be a character vector of length 1");	2529	`error(_("'xlab' must be a character vector of length 1"));`
2530	`if (!isString(ylab) \|\| length(ylab) < 1)`	2530	`if (!isString(ylab) \|\| length(ylab) < 1)`
2531	error("`ylab' must be a character vector of length 1");	2531	`error(_("'ylab' must be a character vector of length 1"));`
2532	`if (!isString(zlab) \|\| length(zlab) < 1)`	2532	`if (!isString(zlab) \|\| length(zlab) < 1)`
2533	error("`zlab' must be a character vector of length 1");	2533	`error(_("'zlab' must be a character vector of length 1"));`
2534		2534
2535	`if (R_FINITE(Shade) && Shade <= 0) Shade = 1;`	2535	`if (R_FINITE(Shade) && Shade <= 0) Shade = 1;`
2536	`if (R_FINITE(ltheta) && R_FINITE(lphi) && R_FINITE(Shade))`	2536	`if (R_FINITE(ltheta) && R_FINITE(lphi) && R_FINITE(Shade))`
2537	`DoLighting = TRUE;`	2537	`DoLighting = TRUE;`
2538	`else`	2538	`else`
Line 2548...	Line 2548...
2548		2548
2549	`/* Parameter Checks */`	2549	`/* Parameter Checks */`
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 @ 28362 – Rev 32380 → 32871