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



		C_free((char *) yyy);
	    }
	}
}
 
/* contour(x,y,z, levels, col, lty) */
 
SEXP do_contour(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP oargs, c, x, y, z, col, lty;
    int i, j, nx, ny, nc, ncol, nlty;

    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\n");
	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\n");
	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\n");
 
    zmin = DBL_MAX;
    zmax = DBL_MIN;
    for (i = 0; i < nx * ny; i++)
	if (R_FINITE(REAL(z)[i])) {

    FindCutPoints(low, high, y1,  x2,  z21, y2,  x2,  z22, y, x, z, npt);
    FindCutPoints(low, high, x2,  y2,  z22, x1,  y2,  z12, x, y, z, npt);
    FindCutPoints(low, high, y2,  x1,  z12, y1,  x1,  z11, y, x, z, npt);
}
 
/* FIXME: [Code consistency] Use macro for the parallel parts of
	  do_contour, do_filledcontour & do_image ...
*/
SEXP do_filledcontour(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP oargs, sx, sy, sz, sc, scol;
    double *x, *y, *z, *c;
    unsigned *col;

 
    /* Check of grid coordinates */
    /* We want them to all be finite */
    /* and in strictly ascending order */
 
    if (nx < 1 || ny < 1) goto badxy;
    if (!R_FINITE(x[0])) goto badxy;
    if (!R_FINITE(y[0])) goto badxy;
    for (i = 1; i < nx; i++)
	if (!R_FINITE(x[i]) || x[i] <= x[i - 1]) goto badxy;
    for (j = 1; j < ny; j++)

    if (call != R_NilValue)
	recordGraphicOperation(op, oargs, dd);
    return R_NilValue;
 
 badxy:
    errorcall(call, "invalid x / y values or limits\n");
 badlev:
    errorcall(call, "invalid contour levels\n");
    return R_NilValue;  /* never used; to keep -Wall happy */
}
 
 
	/*  I m a g e   R e n d e r i n g  */
 
 
/* image(x, y, z, zlim, col) */
SEXP do_image(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP oargs, sx, sy, sz, szlim, sc;
    double *x, *y, *z;
    unsigned *c;
    double xlow, xhigh, ylow, yhigh, zmin = 0., zmax = 0.;
    int i, j, nx, ny, nz, ic, nc, colsave, xpdsave;
    DevDesc *dd = CurrentDevice();
 
    GCheckState(dd);
 

    szlim = CAR(args);
    internalTypeCheck(call, szlim, REALSXP);
    if (length(szlim) != 2 ||
       !R_FINITE(REAL(szlim)[0]) ||
       !R_FINITE(REAL(szlim)[1]) ||
       (zmin = REAL(szlim)[0]) > (zmax = REAL(szlim)[1]))
	errorcall(call, "invalid z limits\n");
    if(zmin == zmax) {/* fix them up, as in graphics.c's GScale(): */
	if(zmin == 0) {
	    zmin = -1;
	    zmax =  1;
	}
	else {
	    xlow = .4 * fabs(zmin);
	    zmin -= xlow;
	    zmax += xlow;
	}
    }
    args = CDR(args);
 
    PROTECT(sc = FixupCol(CAR(args), NA_INTEGER));
    nc = length(sc);
 

    c = (unsigned*)INTEGER(sc);
 
    /* Check of grid coordinates */
    /* We want them to all be finite and in strictly ascending order */
 
    if (nx < 1 || ny < 1) goto badxy;
    if (!R_FINITE(x[0])) goto badxy;
    if (!R_FINITE(y[0])) goto badxy;
    for (i = 1; i < nx; i++)
	if (!R_FINITE(x[i]) || x[i] <= x[i - 1]) goto badxy;
    for (j = 1; j < ny; j++)

	if (i == 0)
	    xlow = x[0];
	else
	    xlow = 0.5 * (x[i] + x[i-1]);
	if (i == nx-1)
	    xhigh = x[i];
	else
	    xhigh = 0.5 * (x[i] + x[i+1]);
 
	for (j = 0; j < ny; j++) {
	    if (R_FINITE(z[i + j * nx])) {

		    if (j == 0)
			ylow = y[0];
		    else
			ylow = 0.5 * (y[j] + y[j - 1]);
		    if (j == ny - 1)
			yhigh = y[j];
		    else
			yhigh = 0.5 * (y[j] + y[j + 1]);
		    GRect(xlow, ylow, xhigh, yhigh,
			  USER, c[ic], NA_INTEGER, dd);
		}

    if (call != R_NilValue)
	recordGraphicOperation(op, oargs, dd);
    return R_NilValue;
 
  badxy:
    errorcall(call, "invalid x / y values or limits\n");
    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  */
 

 
    /* Parameter Checks */
 
    if (!R_FINITE(theta) || !R_FINITE(phi) || !R_FINITE(r) || !R_FINITE(d) ||
	d < 0 || r < 0)
	errorcall(call, "invalid viewing parameters\n");
    if (!R_FINITE(expand) || expand < 0)
	errorcall(call, "invalid expand value\n");
    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\n");
    PROTECT(border = FixupCol(border, dd->gp.fg));
    if (length(border) < 1) errorcall(call, "invalid border specification\n");
 
    GSetState(1, dd);
    GSavePars(dd);
    ProcessInlinePars(args, dd);
    if (length(border) > 1)

Rev 5731	Rev 6098
Line 394...	Line 394...
394	`C_free((char *) yyy);`	394	`C_free((char *) yyy);`
395	`}`	395	`}`
396	`}`	396	`}`
397	`}`	397	`}`
398		398
399	`/* .Internal(contour(x,y,z, levels, col, lty) */`	399	`/* contour(x,y,z, levels, col, lty) */`
400		400
401	`SEXP do_contour(SEXP call, SEXP op, SEXP args, SEXP env)`	401	`SEXP do_contour(SEXP call, SEXP op, SEXP args, SEXP env)`
402	`{`	402	`{`
403	`SEXP oargs, c, x, y, z, col, lty;`	403	`SEXP oargs, c, x, y, z, col, lty;`
404	`int i, j, nx, ny, nc, ncol, nlty;`	404	`int i, j, nx, ny, nc, ncol, nlty;`
Line 450...	Line 450...
450	`if (nc < 1)`	450	`if (nc < 1)`
451	`errorcall(call, "no contour values");`	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");`	455	`errorcall(call, "missing x values\n");`
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");`	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");`	462	`errorcall(call, "missing y values\n");`
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");`	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");`	472	`errorcall(call, "illegal NA contour values\n");`
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 643...	Line 643...
643	`FindCutPoints(low, high, y1, x2, z21, y2, x2, z22, y, x, z, npt);`	643	`FindCutPoints(low, high, y1, x2, z21, y2, x2, z22, y, x, z, npt);`
644	`FindCutPoints(low, high, x2, y2, z22, x1, y2, z12, x, y, z, npt);`	644	`FindCutPoints(low, high, x2, y2, z22, x1, y2, z12, x, y, z, npt);`
645	`FindCutPoints(low, high, y2, x1, z12, y1, x1, z11, y, x, z, npt);`	645	`FindCutPoints(low, high, y2, x1, z12, y1, x1, z11, y, x, z, npt);`
646	`}`	646	`}`
647		647
-		648	`/* FIXME: [Code consistency] Use macro for the parallel parts of`
-		649	`do_contour, do_filledcontour & do_image ...`
-		650	`*/`
648	`SEXP do_filledcontour(SEXP call, SEXP op, SEXP args, SEXP env)`	651	`SEXP do_filledcontour(SEXP call, SEXP op, SEXP args, SEXP env)`
649	`{`	652	`{`
650	`SEXP oargs, sx, sy, sz, sc, scol;`	653	`SEXP oargs, sx, sy, sz, sc, scol;`
651	`double x, y, z, c;`	654	`double x, y, z, c;`
652	`unsigned *col;`	655	`unsigned *col;`
Line 692...	Line 695...
692		695
693	`/* Check of grid coordinates */`	696	`/* Check of grid coordinates */`
694	`/* We want them to all be finite */`	697	`/* We want them to all be finite */`
695	`/* and in strictly ascending order */`	698	`/* and in strictly ascending order */`
696		699
697	`if (nx < 2 \|\| ny < 2) goto badxy;`	700	`if (nx < 1 \|\| ny < 1) goto badxy;`
698	`if (!R_FINITE(x[0])) goto badxy;`	701	`if (!R_FINITE(x[0])) goto badxy;`
699	`if (!R_FINITE(y[0])) goto badxy;`	702	`if (!R_FINITE(y[0])) goto badxy;`
700	`for (i = 1; i < nx; i++)`	703	`for (i = 1; i < nx; i++)`
701	`if (!R_FINITE(x[i]) \|\| x[i] <= x[i - 1]) goto badxy;`	704	`if (!R_FINITE(x[i]) \|\| x[i] <= x[i - 1]) goto badxy;`
702	`for (j = 1; j < ny; j++)`	705	`for (j = 1; j < ny; j++)`
Line 740...	Line 743...
740	`if (call != R_NilValue)`	743	`if (call != R_NilValue)`
741	`recordGraphicOperation(op, oargs, dd);`	744	`recordGraphicOperation(op, oargs, dd);`
742	`return R_NilValue;`	745	`return R_NilValue;`
743		746
744	`badxy:`	747	`badxy:`
745	`errorcall(call, "invalid x / y limits");`	748	`errorcall(call, "invalid x / y values or limits\n");`
746	`badlev:`	749	`badlev:`
747	`errorcall(call, "invalid contour levels");`	750	`errorcall(call, "invalid contour levels\n");`
748	`return R_NilValue; /* never used; to keep -Wall happy */`	751	`return R_NilValue; /* never used; to keep -Wall happy */`
749	`}`	752	`}`
750		753
751		754
752	`/* I m a g e R e n d e r i n g */`	755	`/* I m a g e R e n d e r i n g */`
753		756
754		757
-		758	`/* image(x, y, z, zlim, col) */`
755	`SEXP do_image(SEXP call, SEXP op, SEXP args, SEXP env)`	759	`SEXP do_image(SEXP call, SEXP op, SEXP args, SEXP env)`
756	`{`	760	`{`
757	`SEXP oargs, sx, sy, sz, szlim, sc;`	761	`SEXP oargs, sx, sy, sz, szlim, sc;`
758	`double x, y, *z;`	762	`double x, y, *z;`
759	`unsigned *c;`	763	`unsigned *c;`
760	`double xlow, xhigh, ylow, yhigh, zmin, zmax;`	764	`double xlow, xhigh, ylow, yhigh, zmin = 0., zmax = 0.;`
761	`int i, j, nx, ny, nz, ic, nc, colsave, xpdsave;`	765	`int i, j, nx, ny, nz, ic, nc, colsave, xpdsave;`
762	`DevDesc *dd = CurrentDevice();`	766	`DevDesc *dd = CurrentDevice();`
763		767
764	`GCheckState(dd);`	768	`GCheckState(dd);`
765		769
Line 784...	Line 788...
784	`szlim = CAR(args);`	788	`szlim = CAR(args);`
785	`internalTypeCheck(call, szlim, REALSXP);`	789	`internalTypeCheck(call, szlim, REALSXP);`
786	`if (length(szlim) != 2 \|\|`	790	`if (length(szlim) != 2 \|\|`
787	`!R_FINITE(REAL(szlim)[0]) \|\|`	791	`!R_FINITE(REAL(szlim)[0]) \|\|`
788	`!R_FINITE(REAL(szlim)[1]) \|\|`	792	`!R_FINITE(REAL(szlim)[1]) \|\|`
789	`REAL(szlim)[0] >= REAL(szlim)[1])`	793	`(zmin = REAL(szlim)[0]) > (zmax = REAL(szlim)[1]))`
790	`errorcall(call, "invalid z limits");`	794	`errorcall(call, "invalid z limits\n");`
-		795	`if(zmin == zmax) {/* fix them up, as in graphics.c's GScale(): */`
-		796	`if(zmin == 0) {`
-		797	`zmin = -1;`
-		798	`zmax = 1;`
-		799	`}`
-		800	`else {`
-		801	`xlow = .4 * fabs(zmin);`
791	`zmin = REAL(szlim)[0];`	802	`zmin -= xlow;`
792	`zmax = REAL(szlim)[1];`	803	`zmax += xlow;`
-		804	`}`
-		805	`}`
793	`args = CDR(args);`	806	`args = CDR(args);`
794		807
795	`PROTECT(sc = FixupCol(CAR(args), NA_INTEGER));`	808	`PROTECT(sc = FixupCol(CAR(args), NA_INTEGER));`
796	`nc = length(sc);`	809	`nc = length(sc);`
797		810
Line 803...	Line 816...
803	`c = (unsigned*)INTEGER(sc);`	816	`c = (unsigned*)INTEGER(sc);`
804		817
805	`/* Check of grid coordinates */`	818	`/* Check of grid coordinates */`
806	`/* We want them to all be finite and in strictly ascending order */`	819	`/* We want them to all be finite and in strictly ascending order */`
807		820
808	`if (nx < 2 \|\| ny < 2) goto badxy;`	821	`if (nx < 1 \|\| ny < 1) goto badxy;`
809	`if (!R_FINITE(x[0])) goto badxy;`	822	`if (!R_FINITE(x[0])) goto badxy;`
810	`if (!R_FINITE(y[0])) goto badxy;`	823	`if (!R_FINITE(y[0])) goto badxy;`
811	`for (i = 1; i < nx; i++)`	824	`for (i = 1; i < nx; i++)`
812	`if (!R_FINITE(x[i]) \|\| x[i] <= x[i - 1]) goto badxy;`	825	`if (!R_FINITE(x[i]) \|\| x[i] <= x[i - 1]) goto badxy;`
813	`for (j = 1; j < ny; j++)`	826	`for (j = 1; j < ny; j++)`
Line 824...	Line 837...
824	`if (i == 0)`	837	`if (i == 0)`
825	`xlow = x[0];`	838	`xlow = x[0];`
826	`else`	839	`else`
827	`xlow = 0.5 * (x[i] + x[i-1]);`	840	`xlow = 0.5 * (x[i] + x[i-1]);`
828	`if (i == nx-1)`	841	`if (i == nx-1)`
829	`xhigh = x[nx-1];`	842	`xhigh = x[i];`
830	`else`	843	`else`
831	`xhigh = 0.5 * (x[i] + x[i+1]);`	844	`xhigh = 0.5 * (x[i] + x[i+1]);`
832		845
833	`for (j = 0; j < ny; j++) {`	846	`for (j = 0; j < ny; j++) {`
834	`if (R_FINITE(z[i + j * nx])) {`	847	`if (R_FINITE(z[i + j * nx])) {`
Line 837...	Line 850...
837	`if (j == 0)`	850	`if (j == 0)`
838	`ylow = y[0];`	851	`ylow = y[0];`
839	`else`	852	`else`
840	`ylow = 0.5 * (y[j] + y[j - 1]);`	853	`ylow = 0.5 * (y[j] + y[j - 1]);`
841	`if (j == ny - 1)`	854	`if (j == ny - 1)`
842	`yhigh = y[ny - 1];`	855	`yhigh = y[j];`
843	`else`	856	`else`
844	`yhigh = 0.5 * (y[j] + y[j + 1]);`	857	`yhigh = 0.5 * (y[j] + y[j + 1]);`
845	`GRect(xlow, ylow, xhigh, yhigh,`	858	`GRect(xlow, ylow, xhigh, yhigh,`
846	`USER, c[ic], NA_INTEGER, dd);`	859	`USER, c[ic], NA_INTEGER, dd);`
847	`}`	860	`}`
Line 856...	Line 869...
856	`if (call != R_NilValue)`	869	`if (call != R_NilValue)`
857	`recordGraphicOperation(op, oargs, dd);`	870	`recordGraphicOperation(op, oargs, dd);`
858	`return R_NilValue;`	871	`return R_NilValue;`
859		872
860	`badxy:`	873	`badxy:`
861	`errorcall(call, "invalid x / y limits");`	874	`errorcall(call, "invalid x / y values or limits\n");`
862	`return R_NilValue;/* never used; to keep -Wall happy */`	875	`return R_NilValue;/* never used; to keep -Wall happy */`
863	`}`	876	`}`
864		877
865	`/* P e r s p e c t i v e S u r f a c e P l o t s */`	878	`/* P e r s p e c t i v e S u r f a c e P l o t s */`
866		879
Line 1465...	Line 1478...
1465		1478
1466	`/* Parameter Checks */`	1479	`/* Parameter Checks */`
1467		1480
1468	`if (!R_FINITE(theta) \|\| !R_FINITE(phi) \|\| !R_FINITE(r) \|\| !R_FINITE(d) \|\|`	1481	`if (!R_FINITE(theta) \|\| !R_FINITE(phi) \|\| !R_FINITE(r) \|\| !R_FINITE(d) \|\|`
1469	`d < 0 \|\| r < 0)`	1482	`d < 0 \|\| r < 0)`
1470	`errorcall(call, "invalid viewing parameters");`	1483	`errorcall(call, "invalid viewing parameters\n");`
1471	`if (!R_FINITE(expand) \|\| expand < 0)`	1484	`if (!R_FINITE(expand) \|\| expand < 0)`
1472	`errorcall(call, "invalid expand value");`	1485	`errorcall(call, "invalid expand value\n");`
1473	`if (scale == NA_LOGICAL)`	1486	`if (scale == NA_LOGICAL)`
1474	`scale = 0;`	1487	`scale = 0;`
1475		1488
1476	`dd = GNewPlot(call != R_NilValue, NA_LOGICAL);`	1489	`dd = GNewPlot(call != R_NilValue, NA_LOGICAL);`
1477		1490
1478	`PROTECT(col = FixupCol(col, dd->gp.bg));`	1491	`PROTECT(col = FixupCol(col, dd->gp.bg));`
1479	`ncol = LENGTH(col);`	1492	`ncol = LENGTH(col);`
1480	`if (ncol < 1) errorcall(call, "invalid col specification");`	1493	`if (ncol < 1) errorcall(call, "invalid col specification\n");`
1481	`PROTECT(border = FixupCol(border, dd->gp.fg));`	1494	`PROTECT(border = FixupCol(border, dd->gp.fg));`
1482	`if (length(border) < 1) errorcall(call, "invalid border specification");`	1495	`if (length(border) < 1) errorcall(call, "invalid border specification\n");`
1483		1496
1484	`GSetState(1, dd);`	1497	`GSetState(1, dd);`
1485	`GSavePars(dd);`	1498	`GSavePars(dd);`
1486	`ProcessInlinePars(args, dd);`	1499	`ProcessInlinePars(args, dd);`
1487	`if (length(border) > 1)`	1500	`if (length(border) > 1)`

The R Project SVN R

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