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



	return 0;
    else
	return n;
}
 
/*
 * Generate a list of segments for a single level
 */
static SEGP* contourLines(double *x, int nx, double *y, int ny,
			 double *z, double zc, double atom)
{

	    zll = z[k];
	    zhl = z[k + 1];
	    zlh = z[k + nx];
	    zhh = z[k + nx + 1];
 
	    /* If the value at a corner is exactly equal to a contour level,
	     * change that value by a tiny amount */
 
	    if (zll == zc) zll += atom;
	    if (zhl == zc) zhl += atom;
	    if (zlh == zc) zlh += atom;

	}
    }
    return segmentDB;
}
 
/* maximal number of line segments of one contour segment:
 * for preventing infinite loops -- shouldn't be needed --> warning */
#define MAX_ns 25000
 
#define CONTOUR_LIST_STEP 100
#define CONTOUR_LIST_LEVEL 0

	SET_VECTOR_ELT(templist, i, VECTOR_ELT(oldlist, i));
    UNPROTECT(1);
    return templist;
}
 
/*
 * Store the list of segments for a single level in the SEXP
 * list that will be returned to the user
 */
int addContourLines(double *x, int nx, double *y, int ny,
		     double *z, double zc, double atom,

		    seg->next = start;
		    start = seg;
		    xend = start->x0;
		    yend = start->y0;
		}
 
		/* ns := #{segments of polyline} -- need to allocate */
		s = start;
		ns = 0;
		/* MAX_ns: prevent inf.loop (shouldn't be needed) */
		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;
 
		/*
		 * "write" the contour locations into the list of contours

		}
		REAL(xsxp)[ns] = s->x1;
		REAL(ysxp)[ns] = s->y1;
		SET_VECTOR_ELT(ctr, CONTOUR_LIST_X, xsxp);
		SET_VECTOR_ELT(ctr, CONTOUR_LIST_Y, ysxp);
		/*
		 * Set the names attribute for the contour
		 * So that users can extract components using
		 * meaningful names
		 */
		PROTECT(names = allocVector(STRSXP, 3));
		SET_STRING_ELT(names, 0, mkChar("level"));
		SET_STRING_ELT(names, 1, mkChar("x"));
		SET_STRING_ELT(names, 2, mkChar("y"));
		setAttrib(ctr, R_NamesSymbol, names);
		/*
		 * We're about to add another line to the list ...
		 */
		nlines += 1;
		nc = LENGTH(VECTOR_ELT(container, 0));
		if (nlines == nc)
		    /* Where does this get UNPROTECTed? */
		    SET_VECTOR_ELT(container, 0,
				   growList(VECTOR_ELT(container, 0)));
		SET_VECTOR_ELT(VECTOR_ELT(container, 0), nlines - 1, ctr);
		UNPROTECT(5);
	    }
	}
    return nlines;
}
 
/*
 * Given nx x values, ny y values, nx*ny z values,
 * and nl cut-values in z ...
 * ... produce a list of contour lines:
 *   list of sub-lists
 *     sub-list = x vector, y vector, and cut-value.

    char *vmax;
    int i, nlines, len;
    double atom, zmin, zmax;
    SEGP* segmentDB;
    SEXP container, mainlist, templist;
    /*
     * "tie-breaker" values
     */
    zmin = DBL_MAX;
    zmax = DBL_MIN;
    for (i = 0; i < nx * ny; i++)

    /* 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 * (..).
     * see also MAX_ns above */
    atom = 1e-3 * (zmax - zmin);
    /*
     * Create a "container" which is a list with only 1 element.
     * The element is the list of lines that will be built up.
     * I create the container because this allows me to PROTECT
     * the container once here and then UNPROTECT it at the end of
     * this function and, as long as I always work with
     * VECTOR_ELT(container, 0) and SET_VECTOR_ELT(container, 0)
     * in functions called from here, I don't need to worry about
     * protectin the list that I am building up.
     * Why bother?  Because the list I am building can potentially
     * grow and it's awkward to get the PROTECTs/UNPROTECTs right
     * when you're in a loop and growing a list.
     */
    container = PROTECT(allocVector(VECSXP, 1));
    /*
     * Create "large" list (will trim excess at the end if necesary)
     */
    SET_VECTOR_ELT(container, 0, allocVector(VECSXP, CONTOUR_LIST_STEP));
    nlines = 0;
    /*
     * Add lines for each contour level
     */
    for (i = 0; i < nl; i++) {
	/*
	 * The vmaxget/set is to manage the memory that gets
	 * R_alloc'ed in the creation of the segmentDB structure
	 */
	vmax = vmaxget();
	/*
	 * Generate a segment database
	 */
	segmentDB = contourLines(x, nx, y, ny, z, levels[i], atom);
	/*
	 * Add lines to the list based on the segment database
	 */
	nlines = addContourLines(x, nx, y, ny, z, levels[i],
				 atom, segmentDB, nlines,
				 container);
	vmaxset(vmax);
    }
    /*
     * Trim the list of lines to the appropriate length.
     */
    len = LENGTH(VECTOR_ELT(container, 0));
    if (nlines < len) {
	mainlist = VECTOR_ELT(container, 0);
	templist = PROTECT(allocVector(VECSXP, nlines));
	for (i=0; i<nlines; i++)
	    SET_VECTOR_ELT(templist, i, VECTOR_ELT(mainlist, i));
	mainlist = templist;
	UNPROTECT(1);  /* UNPROTECT templist */
    } else
	mainlist = VECTOR_ELT(container, 0);
    UNPROTECT(1);  /* UNPROTECT container */
    return mainlist;
}
 

    /* levels */
    c = CAR(args);
    internalTypeCheck(call, c, REALSXP);
    nc = LENGTH(c);
    args = CDR(args);
 
    return GEcontourLines(REAL(x), nx, REAL(y), ny, REAL(z), REAL(c), nc, dd);
}
 
/*
 * The *base graphics* function contour() and the *general base*
 * function contourLines() use the same code to generate contour lines
 * (i.e., the function contourLines())
 *
 * I had a look at extracting the code that draws the labels
 * into a *general base* function
 * (e.g., into some sort of labelLines() function),
 * but the code is too base-graphics-specific (e.g., one of the
 * labelling methods seeks the location closest to the edge of the
 * plotting region) so I've left it alone for now.
 *
 * This does mean that the contourLines() function is part of the
 * graphics engine, but the contour() function is part of the
 * base graphics system.
 */
 
static void contour(SEXP x, int nx, SEXP y, int ny, SEXP z,
		    double zc,
		    SEXP labels, int cnum,
		    Rboolean drawLabels, int method,
		    Rboolean vectorFonts, int typeface, int fontindex,
		    double atom, DevDesc *dd)

	    xxx[ns] = s->x1;
	    yyy[ns++] = s->y1;
#ifdef DEBUG_contour
	    Rprintf("  [%2d,%2d]: (x,y)[1:%d] = ", i,j, ns);
	    if(ns >= 5)
		Rprintf(" (%g,%g), (%g,%g), ..., (%g,%g)\n",
			xxx[0],yyy[0], xxx[1],yyy[1], xxx[ns-1],yyy[ns-1]);
	    else
		for(iii = 0; iii < ns; iii++)
		    Rprintf(" (%g,%g)%s", xxx[iii],yyy[iii],
			    (iii < ns-1) ? "," : "\n");
#endif
 
	    GMode(1, dd);
 
	    if (drawLabels) {
		/* If user supplied labels, use i'th one of them

		buffer[strlen(buffer)+1] = '\0';
		buffer[strlen(buffer)] = ' ';
 
		if (vectorFonts) {
		    /* 1, 1 => sans serif, basic font */
		    labelDistance =
			GVStrWidth((unsigned char *)buffer, typeface, fontindex,
				   INCHES, dd);
		    labelHeight =
			GVStrHeight((unsigned char *)buffer, typeface, fontindex,
				    INCHES, dd);
		}
		else {
		    labelDistance = GStrWidth(buffer, INCHES, dd);

    UNPROTECT_PTR(label1); /* pwwwargh! This is messy, but last thing
			      protected is likely labelList, and that needs
			      to be preserved across calls */
}
 
/* contour(x, y, z, levels, labels, labcex, drawlabels,
 *         method, vfont, col = col, lty = lty, lwd = lwd)
 */
SEXP do_contour(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP oargs, c, x, y, z, vfont, col, rawcol, lty, lwd, labels;

	Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
	if (Rf_gpptr(dd)->lty == NA_INTEGER)
	    Rf_gpptr(dd)->lty = ltysave;
	if (isNAcol(rawcol, i, ncol))
	    Rf_gpptr(dd)->col = colsave;
	else
	    Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
	Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
	if (!R_FINITE(Rf_gpptr(dd)->lwd))
	    Rf_gpptr(dd)->lwd = lwdsave;
	Rf_gpptr(dd)->cex = labcex;
	contour(x, nx, y, ny, z, REAL(c)[i], labels, i,
		drawLabels, method-1,
		vectorFonts, typeface, fontindex, atom, dd);
	vmaxset(vmax);
    }
    GMode(0, dd);
    vmaxset(vmax0);
    Rf_gpptr(dd)->lty = ltysave;
    Rf_gpptr(dd)->col = colsave;
    Rf_gpptr(dd)->lwd = lwdsave;
    Rf_gpptr(dd)->cex = cexsave;

    d_frac = 0.1*(max - min);
    nint = nTicks - 1; if(!nint) nint++;
    i = nint;
    GPretty(&min, &max, &nint);
    /* GPretty() rarely gives values too much outside range ..
       2D axis() clip these, we play cheaper */
    while((min < range[0] - d_frac || range[1] + d_frac < max) && i < 20) {
	nint = ++i;
	min = range[0];
	max = range[1];
	GPretty(&min, &max, &nint);

        PerspBox(0, REAL(xlim), REAL(ylim), REAL(zlim), dd);
	if (doaxes) {
	    SEXP xl = STRING_ELT(xlab, 0), yl = STRING_ELT(ylab, 0),
		zl = STRING_ELT(zlab, 0);
	    PerspAxes(REAL(xlim), REAL(ylim), REAL(zlim),
		      (xl == NA_STRING)? "" : CHAR(xl),
		      (yl == NA_STRING)? "" : CHAR(yl),
		      (zl == NA_STRING)? "" : CHAR(zl),
		      nTicks, tickType, dd);
	}
    }

Rev 30980	Rev 31216
Line 459...	Line 459...
459	`return 0;`	459	`return 0;`
460	`else`	460	`else`
461	`return n;`	461	`return n;`
462	`}`	462	`}`
463		463
464	`/*`	464	`/*`
465	`* Generate a list of segments for a single level`	465	`* Generate a list of segments for a single level`
466	`*/`	466	`*/`
467	`static SEGP* contourLines(double x, int nx, double y, int ny,`	467	`static SEGP* contourLines(double x, int nx, double y, int ny,`
468	`double *z, double zc, double atom)`	468	`double *z, double zc, double atom)`
469	`{`	469	`{`
Line 492...	Line 492...
492	`zll = z[k];`	492	`zll = z[k];`
493	`zhl = z[k + 1];`	493	`zhl = z[k + 1];`
494	`zlh = z[k + nx];`	494	`zlh = z[k + nx];`
495	`zhh = z[k + nx + 1];`	495	`zhh = z[k + nx + 1];`
496		496
497	`/* If the value at a corner is exactly equal to a contour level,`	497	`/* If the value at a corner is exactly equal to a contour level,`
498	`* change that value by a tiny amount */`	498	`* change that value by a tiny amount */`
499		499
500	`if (zll == zc) zll += atom;`	500	`if (zll == zc) zll += atom;`
501	`if (zhl == zc) zhl += atom;`	501	`if (zhl == zc) zhl += atom;`
502	`if (zlh == zc) zlh += atom;`	502	`if (zlh == zc) zlh += atom;`
Line 635...	Line 635...
635	`}`	635	`}`
636	`}`	636	`}`
637	`return segmentDB;`	637	`return segmentDB;`
638	`}`	638	`}`
639		639
640	`/* maximal number of line segments of one contour segment:`	640	`/* maximal number of line segments of one contour segment:`
641	`* for preventing infinite loops -- shouldn't be needed --> warning */`	641	`* for preventing infinite loops -- shouldn't be needed --> warning */`
642	`#define MAX_ns 25000`	642	`#define MAX_ns 25000`
643		643
644	`#define CONTOUR_LIST_STEP 100`	644	`#define CONTOUR_LIST_STEP 100`
645	`#define CONTOUR_LIST_LEVEL 0`	645	`#define CONTOUR_LIST_LEVEL 0`
Line 655...	Line 655...
655	`SET_VECTOR_ELT(templist, i, VECTOR_ELT(oldlist, i));`	655	`SET_VECTOR_ELT(templist, i, VECTOR_ELT(oldlist, i));`
656	`UNPROTECT(1);`	656	`UNPROTECT(1);`
657	`return templist;`	657	`return templist;`
658	`}`	658	`}`
659		659
660	`/*`	660	`/*`
661	`* Store the list of segments for a single level in the SEXP`	661	`* Store the list of segments for a single level in the SEXP`
662	`* list that will be returned to the user`	662	`* list that will be returned to the user`
663	`*/`	663	`*/`
664	`int addContourLines(double x, int nx, double y, int ny,`	664	`int addContourLines(double x, int nx, double y, int ny,`
665	`double *z, double zc, double atom,`	665	`double *z, double zc, double atom,`
Line 706...	Line 706...
706	`seg->next = start;`	706	`seg->next = start;`
707	`start = seg;`	707	`start = seg;`
708	`xend = start->x0;`	708	`xend = start->x0;`
709	`yend = start->y0;`	709	`yend = start->y0;`
710	`}`	710	`}`
711		711
712	`/* ns := #{segments of polyline} -- need to allocate */`	712	`/* ns := #{segments of polyline} -- need to allocate */`
713	`s = start;`	713	`s = start;`
714	`ns = 0;`	714	`ns = 0;`
715	`/* MAX_ns: prevent inf.loop (shouldn't be needed) */`	715	`/* MAX_ns: prevent inf.loop (shouldn't be needed) */`
716	`while (s && ns < MAX_ns) {`	716	`while (s && ns < MAX_ns) {`
717	`ns++;`	717	`ns++;`
718	`s = s->next;`	718	`s = s->next;`
719	`}`	719	`}`
720	`if(ns == MAX_ns)`	720	`if(ns == MAX_ns)`
721	`warning("contour(): circular/long seglist -- bug.report()!");`	721	`warning("contour(): circular/long seglist -- bug.report()!");`
722		722
723	`/* countour midpoint : use for labelling sometime (not yet!) */`	723	`/* countour midpoint : use for labelling sometime (not yet!) */`
724	`if (ns > 3) ns2 = ns/2; else ns2 = -1;`	724	`if (ns > 3) ns2 = ns/2; else ns2 = -1;`
725		725
726	`/*`	726	`/*`
727	`* "write" the contour locations into the list of contours`	727	`* "write" the contour locations into the list of contours`
Line 743...	Line 743...
743	`}`	743	`}`
744	`REAL(xsxp)[ns] = s->x1;`	744	`REAL(xsxp)[ns] = s->x1;`
745	`REAL(ysxp)[ns] = s->y1;`	745	`REAL(ysxp)[ns] = s->y1;`
746	`SET_VECTOR_ELT(ctr, CONTOUR_LIST_X, xsxp);`	746	`SET_VECTOR_ELT(ctr, CONTOUR_LIST_X, xsxp);`
747	`SET_VECTOR_ELT(ctr, CONTOUR_LIST_Y, ysxp);`	747	`SET_VECTOR_ELT(ctr, CONTOUR_LIST_Y, ysxp);`
748	`/*`	748	`/*`
749	`* Set the names attribute for the contour`	749	`* Set the names attribute for the contour`
750	`* So that users can extract components using`	750	`* So that users can extract components using`
751	`* meaningful names`	751	`* meaningful names`
752	`*/`	752	`*/`
753	`PROTECT(names = allocVector(STRSXP, 3));`	753	`PROTECT(names = allocVector(STRSXP, 3));`
754	`SET_STRING_ELT(names, 0, mkChar("level"));`	754	`SET_STRING_ELT(names, 0, mkChar("level"));`
755	`SET_STRING_ELT(names, 1, mkChar("x"));`	755	`SET_STRING_ELT(names, 1, mkChar("x"));`
756	`SET_STRING_ELT(names, 2, mkChar("y"));`	756	`SET_STRING_ELT(names, 2, mkChar("y"));`
757	`setAttrib(ctr, R_NamesSymbol, names);`	757	`setAttrib(ctr, R_NamesSymbol, names);`
758	`/*`	758	`/*`
759	`* We're about to add another line to the list ...`	759	`* We're about to add another line to the list ...`
760	`*/`	760	`*/`
761	`nlines += 1;`	761	`nlines += 1;`
762	`nc = LENGTH(VECTOR_ELT(container, 0));`	762	`nc = LENGTH(VECTOR_ELT(container, 0));`
763	`if (nlines == nc)`	763	`if (nlines == nc)`
764	`/* Where does this get UNPROTECTed? */`	764	`/* Where does this get UNPROTECTed? */`
765	`SET_VECTOR_ELT(container, 0,`	765	`SET_VECTOR_ELT(container, 0,`
766	`growList(VECTOR_ELT(container, 0)));`	766	`growList(VECTOR_ELT(container, 0)));`
767	`SET_VECTOR_ELT(VECTOR_ELT(container, 0), nlines - 1, ctr);`	767	`SET_VECTOR_ELT(VECTOR_ELT(container, 0), nlines - 1, ctr);`
768	`UNPROTECT(5);`	768	`UNPROTECT(5);`
769	`}`	769	`}`
770	`}`	770	`}`
771	`return nlines;`	771	`return nlines;`
772	`}`	772	`}`
773		773
774	`/*`	774	`/*`
775	`* Given nx x values, ny y values, nx*ny z values,`	775	`* Given nx x values, ny y values, nx*ny z values,`
776	`* and nl cut-values in z ...`	776	`* and nl cut-values in z ...`
777	`* ... produce a list of contour lines:`	777	`* ... produce a list of contour lines:`
778	`* list of sub-lists`	778	`* list of sub-lists`
779	`* sub-list = x vector, y vector, and cut-value.`	779	`* sub-list = x vector, y vector, and cut-value.`
Line 785...	Line 785...
785	`char *vmax;`	785	`char *vmax;`
786	`int i, nlines, len;`	786	`int i, nlines, len;`
787	`double atom, zmin, zmax;`	787	`double atom, zmin, zmax;`
788	`SEGP* segmentDB;`	788	`SEGP* segmentDB;`
789	`SEXP container, mainlist, templist;`	789	`SEXP container, mainlist, templist;`
790	`/*`	790	`/*`
791	`* "tie-breaker" values`	791	`* "tie-breaker" values`
792	`*/`	792	`*/`
793	`zmin = DBL_MAX;`	793	`zmin = DBL_MAX;`
794	`zmax = DBL_MIN;`	794	`zmax = DBL_MIN;`
795	`for (i = 0; i < nx * ny; i++)`	795	`for (i = 0; i < nx * ny; i++)`
Line 808...	Line 808...
808	`/* change to 1e-3, reconsidered because of PR#897`	808	`/* change to 1e-3, reconsidered because of PR#897`
809	`* but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().`	809	`* but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().`
810	`* maybe something like 16 * DBL_EPSILON * (..).`	810	`* maybe something like 16 * DBL_EPSILON * (..).`
811	`* see also MAX_ns above */`	811	`* see also MAX_ns above */`
812	`atom = 1e-3 * (zmax - zmin);`	812	`atom = 1e-3 * (zmax - zmin);`
813	`/*`	813	`/*`
814	`* Create a "container" which is a list with only 1 element.`	814	`* Create a "container" which is a list with only 1 element.`
815	`* The element is the list of lines that will be built up.`	815	`* The element is the list of lines that will be built up.`
816	`* I create the container because this allows me to PROTECT`	816	`* I create the container because this allows me to PROTECT`
817	`* the container once here and then UNPROTECT it at the end of`	817	`* the container once here and then UNPROTECT it at the end of`
818	`* this function and, as long as I always work with`	818	`* this function and, as long as I always work with`
819	`* VECTOR_ELT(container, 0) and SET_VECTOR_ELT(container, 0)`	819	`* VECTOR_ELT(container, 0) and SET_VECTOR_ELT(container, 0)`
820	`* in functions called from here, I don't need to worry about`	820	`* in functions called from here, I don't need to worry about`
821	`* protectin the list that I am building up.`	821	`* protectin the list that I am building up.`
822	`* Why bother? Because the list I am building can potentially`	822	`* Why bother? Because the list I am building can potentially`
823	`* grow and it's awkward to get the PROTECTs/UNPROTECTs right`	823	`* grow and it's awkward to get the PROTECTs/UNPROTECTs right`
824	`* when you're in a loop and growing a list.`	824	`* when you're in a loop and growing a list.`
825	`*/`	825	`*/`
826	`container = PROTECT(allocVector(VECSXP, 1));`	826	`container = PROTECT(allocVector(VECSXP, 1));`
827	`/*`	827	`/*`
828	`* Create "large" list (will trim excess at the end if necesary)`	828	`* Create "large" list (will trim excess at the end if necesary)`
829	`*/`	829	`*/`
830	`SET_VECTOR_ELT(container, 0, allocVector(VECSXP, CONTOUR_LIST_STEP));`	830	`SET_VECTOR_ELT(container, 0, allocVector(VECSXP, CONTOUR_LIST_STEP));`
831	`nlines = 0;`	831	`nlines = 0;`
832	`/*`	832	`/*`
833	`* Add lines for each contour level`	833	`* Add lines for each contour level`
834	`*/`	834	`*/`
835	`for (i = 0; i < nl; i++) {`	835	`for (i = 0; i < nl; i++) {`
836	`/*`	836	`/*`
837	`* The vmaxget/set is to manage the memory that gets`	837	`* The vmaxget/set is to manage the memory that gets`
838	`* R_alloc'ed in the creation of the segmentDB structure`	838	`* R_alloc'ed in the creation of the segmentDB structure`
839	`*/`	839	`*/`
840	`vmax = vmaxget();`	840	`vmax = vmaxget();`
841	`/*`	841	`/*`
842	`* Generate a segment database`	842	`* Generate a segment database`
843	`*/`	843	`*/`
844	`segmentDB = contourLines(x, nx, y, ny, z, levels[i], atom);`	844	`segmentDB = contourLines(x, nx, y, ny, z, levels[i], atom);`
845	`/*`	845	`/*`
846	`* Add lines to the list based on the segment database`	846	`* Add lines to the list based on the segment database`
847	`*/`	847	`*/`
848	`nlines = addContourLines(x, nx, y, ny, z, levels[i],`	848	`nlines = addContourLines(x, nx, y, ny, z, levels[i],`
849	`atom, segmentDB, nlines,`	849	`atom, segmentDB, nlines,`
850	`container);`	850	`container);`
851	`vmaxset(vmax);`	851	`vmaxset(vmax);`
852	`}`	852	`}`
853	`/*`	853	`/*`
854	`* Trim the list of lines to the appropriate length.`	854	`* Trim the list of lines to the appropriate length.`
855	`*/`	855	`*/`
856	`len = LENGTH(VECTOR_ELT(container, 0));`	856	`len = LENGTH(VECTOR_ELT(container, 0));`
857	`if (nlines < len) {`	857	`if (nlines < len) {`
858	`mainlist = VECTOR_ELT(container, 0);`	858	`mainlist = VECTOR_ELT(container, 0);`
859	`templist = PROTECT(allocVector(VECSXP, nlines));`	859	`templist = PROTECT(allocVector(VECSXP, nlines));`
860	`for (i=0; i<nlines; i++)`	860	`for (i=0; i<nlines; i++)`
861	`SET_VECTOR_ELT(templist, i, VECTOR_ELT(mainlist, i));`	861	`SET_VECTOR_ELT(templist, i, VECTOR_ELT(mainlist, i));`
862	`mainlist = templist;`	862	`mainlist = templist;`
863	`UNPROTECT(1); /* UNPROTECT templist */`	863	`UNPROTECT(1); /* UNPROTECT templist */`
864	`} else`	864	`} else`
865	`mainlist = VECTOR_ELT(container, 0);`	865	`mainlist = VECTOR_ELT(container, 0);`
866	`UNPROTECT(1); /* UNPROTECT container */`	866	`UNPROTECT(1); /* UNPROTECT container */`
867	`return mainlist;`	867	`return mainlist;`
868	`}`	868	`}`
869		869
Line 894...	Line 894...
894	`/* levels */`	894	`/* levels */`
895	`c = CAR(args);`	895	`c = CAR(args);`
896	`internalTypeCheck(call, c, REALSXP);`	896	`internalTypeCheck(call, c, REALSXP);`
897	`nc = LENGTH(c);`	897	`nc = LENGTH(c);`
898	`args = CDR(args);`	898	`args = CDR(args);`
899		899
900	`return GEcontourLines(REAL(x), nx, REAL(y), ny, REAL(z), REAL(c), nc, dd);`	900	`return GEcontourLines(REAL(x), nx, REAL(y), ny, REAL(z), REAL(c), nc, dd);`
901	`}`	901	`}`
902		902
903	`/*`	903	`/*`
904	`* The base graphics function contour() and the general base`	904	`* The base graphics function contour() and the general base`
905	`* function contourLines() use the same code to generate contour lines`	905	`* function contourLines() use the same code to generate contour lines`
906	`* (i.e., the function contourLines())`	906	`* (i.e., the function contourLines())`
907	`*`	907	`*`
908	`* I had a look at extracting the code that draws the labels`	908	`* I had a look at extracting the code that draws the labels`
909	`* into a general base function`	909	`* into a general base function`
910	`* (e.g., into some sort of labelLines() function),`	910	`* (e.g., into some sort of labelLines() function),`
911	`* but the code is too base-graphics-specific (e.g., one of the`	911	`* but the code is too base-graphics-specific (e.g., one of the`
912	`* labelling methods seeks the location closest to the edge of the`	912	`* labelling methods seeks the location closest to the edge of the`
913	`* plotting region) so I've left it alone for now.`	913	`* plotting region) so I've left it alone for now.`
914	`*`	914	`*`
915	`* This does mean that the contourLines() function is part of the`	915	`* This does mean that the contourLines() function is part of the`
916	`* graphics engine, but the contour() function is part of the`	916	`* graphics engine, but the contour() function is part of the`
917	`* base graphics system.`	917	`* base graphics system.`
918	`*/`	918	`*/`
919		919
920	`static void contour(SEXP x, int nx, SEXP y, int ny, SEXP z,`	920	`static void contour(SEXP x, int nx, SEXP y, int ny, SEXP z,`
921	`double zc,`	921	`double zc,`
922	`SEXP labels, int cnum,`	922	`SEXP labels, int cnum,`
923	`Rboolean drawLabels, int method,`	923	`Rboolean drawLabels, int method,`
924	`Rboolean vectorFonts, int typeface, int fontindex,`	924	`Rboolean vectorFonts, int typeface, int fontindex,`
925	`double atom, DevDesc *dd)`	925	`double atom, DevDesc *dd)`
Line 1034...	Line 1034...
1034	`xxx[ns] = s->x1;`	1034	`xxx[ns] = s->x1;`
1035	`yyy[ns++] = s->y1;`	1035	`yyy[ns++] = s->y1;`
1036	`#ifdef DEBUG_contour`	1036	`#ifdef DEBUG_contour`
1037	`Rprintf(" [%2d,%2d]: (x,y)[1:%d] = ", i,j, ns);`	1037	`Rprintf(" [%2d,%2d]: (x,y)[1:%d] = ", i,j, ns);`
1038	`if(ns >= 5)`	1038	`if(ns >= 5)`
1039	`Rprintf(" (%g,%g), (%g,%g), ..., (%g,%g)\n",`	1039	`Rprintf(" (%g,%g), (%g,%g), ..., (%g,%g)\n",`
1040	`xxx[0],yyy[0], xxx[1],yyy[1], xxx[ns-1],yyy[ns-1]);`	1040	`xxx[0],yyy[0], xxx[1],yyy[1], xxx[ns-1],yyy[ns-1]);`
1041	`else`	1041	`else`
1042	`for(iii = 0; iii < ns; iii++)`	1042	`for(iii = 0; iii < ns; iii++)`
1043	`Rprintf(" (%g,%g)%s", xxx[iii],yyy[iii],`	1043	`Rprintf(" (%g,%g)%s", xxx[iii],yyy[iii],`
1044	`(iii < ns-1) ? "," : "\n");`	1044	`(iii < ns-1) ? "," : "\n");`
1045	`#endif`	1045	`#endif`
1046		1046
1047	`GMode(1, dd);`	1047	`GMode(1, dd);`
1048		1048
1049	`if (drawLabels) {`	1049	`if (drawLabels) {`
1050	`/* If user supplied labels, use i'th one of them`	1050	`/* If user supplied labels, use i'th one of them`
Line 1064...	Line 1064...
1064	`buffer[strlen(buffer)+1] = '\0';`	1064	`buffer[strlen(buffer)+1] = '\0';`
1065	`buffer[strlen(buffer)] = ' ';`	1065	`buffer[strlen(buffer)] = ' ';`
1066		1066
1067	`if (vectorFonts) {`	1067	`if (vectorFonts) {`
1068	`/* 1, 1 => sans serif, basic font */`	1068	`/* 1, 1 => sans serif, basic font */`
1069	`labelDistance =`	1069	`labelDistance =`
1070	`GVStrWidth((unsigned char *)buffer, typeface, fontindex,`	1070	`GVStrWidth((unsigned char *)buffer, typeface, fontindex,`
1071	`INCHES, dd);`	1071	`INCHES, dd);`
1072	`labelHeight =`	1072	`labelHeight =`
1073	`GVStrHeight((unsigned char *)buffer, typeface, fontindex,`	1073	`GVStrHeight((unsigned char *)buffer, typeface, fontindex,`
1074	`INCHES, dd);`	1074	`INCHES, dd);`
1075	`}`	1075	`}`
1076	`else {`	1076	`else {`
1077	`labelDistance = GStrWidth(buffer, INCHES, dd);`	1077	`labelDistance = GStrWidth(buffer, INCHES, dd);`
Line 1352...	Line 1352...
1352	`UNPROTECT_PTR(label1); /* pwwwargh! This is messy, but last thing`	1352	`UNPROTECT_PTR(label1); /* pwwwargh! This is messy, but last thing`
1353	`protected is likely labelList, and that needs`	1353	`protected is likely labelList, and that needs`
1354	`to be preserved across calls */`	1354	`to be preserved across calls */`
1355	`}`	1355	`}`
1356		1356
1357	`/* contour(x, y, z, levels, labels, labcex, drawlabels,`	1357	`/* contour(x, y, z, levels, labels, labcex, drawlabels,`
1358	`* method, vfont, col = col, lty = lty, lwd = lwd)`	1358	`* method, vfont, col = col, lty = lty, lwd = lwd)`
1359	`*/`	1359	`*/`
1360	`SEXP do_contour(SEXP call, SEXP op, SEXP args, SEXP env)`	1360	`SEXP do_contour(SEXP call, SEXP op, SEXP args, SEXP env)`
1361	`{`	1361	`{`
1362	`SEXP oargs, c, x, y, z, vfont, col, rawcol, lty, lwd, labels;`	1362	`SEXP oargs, c, x, y, z, vfont, col, rawcol, lty, lwd, labels;`
Line 1515...	Line 1515...
1515	`Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];`	1515	`Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];`
1516	`if (Rf_gpptr(dd)->lty == NA_INTEGER)`	1516	`if (Rf_gpptr(dd)->lty == NA_INTEGER)`
1517	`Rf_gpptr(dd)->lty = ltysave;`	1517	`Rf_gpptr(dd)->lty = ltysave;`
1518	`if (isNAcol(rawcol, i, ncol))`	1518	`if (isNAcol(rawcol, i, ncol))`
1519	`Rf_gpptr(dd)->col = colsave;`	1519	`Rf_gpptr(dd)->col = colsave;`
1520	`else`	1520	`else`
1521	`Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];`	1521	`Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];`
1522	`Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];`	1522	`Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];`
1523	`if (Rf_gpptr(dd)->lwd == NA_REAL)`	1523	`if (!R_FINITE(Rf_gpptr(dd)->lwd))`
1524	`Rf_gpptr(dd)->lwd = lwdsave;`	1524	`Rf_gpptr(dd)->lwd = lwdsave;`
1525	`Rf_gpptr(dd)->cex = labcex;`	1525	`Rf_gpptr(dd)->cex = labcex;`
1526	`contour(x, nx, y, ny, z, REAL(c)[i], labels, i,`	1526	`contour(x, nx, y, ny, z, REAL(c)[i], labels, i,`
1527	`drawLabels, method-1,`	1527	`drawLabels, method-1,`
1528	`vectorFonts, typeface, fontindex, atom, dd);`	1528	`vectorFonts, typeface, fontindex, atom, dd);`
1529	`vmaxset(vmax);`	1529	`vmaxset(vmax);`
1530	`}`	1530	`}`
1531	`GMode(0, dd);`	1531	`GMode(0, dd);`
1532	`vmaxset(vmax0);`	1532	`vmaxset(vmax0);`
1533	`Rf_gpptr(dd)->lty = ltysave;`	1533	`Rf_gpptr(dd)->lty = ltysave;`
1534	`Rf_gpptr(dd)->col = colsave;`	1534	`Rf_gpptr(dd)->col = colsave;`
1535	`Rf_gpptr(dd)->lwd = lwdsave;`	1535	`Rf_gpptr(dd)->lwd = lwdsave;`
1536	`Rf_gpptr(dd)->cex = cexsave;`	1536	`Rf_gpptr(dd)->cex = cexsave;`
Line 2240...	Line 2240...
2240	`d_frac = 0.1*(max - min);`	2240	`d_frac = 0.1*(max - min);`
2241	`nint = nTicks - 1; if(!nint) nint++;`	2241	`nint = nTicks - 1; if(!nint) nint++;`
2242	`i = nint;`	2242	`i = nint;`
2243	`GPretty(&min, &max, &nint);`	2243	`GPretty(&min, &max, &nint);`
2244	`/* GPretty() rarely gives values too much outside range ..`	2244	`/* GPretty() rarely gives values too much outside range ..`
2245	`2D axis() clip these, we play cheaper */`	2245	`2D axis() clip these, we play cheaper */`
2246	`while((min < range[0] - d_frac \|\| range[1] + d_frac < max) && i < 20) {`	2246	`while((min < range[0] - d_frac \|\| range[1] + d_frac < max) && i < 20) {`
2247	`nint = ++i;`	2247	`nint = ++i;`
2248	`min = range[0];`	2248	`min = range[0];`
2249	`max = range[1];`	2249	`max = range[1];`
2250	`GPretty(&min, &max, &nint);`	2250	`GPretty(&min, &max, &nint);`
Line 2616...	Line 2616...
2616	`PerspBox(0, REAL(xlim), REAL(ylim), REAL(zlim), dd);`	2616	`PerspBox(0, REAL(xlim), REAL(ylim), REAL(zlim), dd);`
2617	`if (doaxes) {`	2617	`if (doaxes) {`
2618	`SEXP xl = STRING_ELT(xlab, 0), yl = STRING_ELT(ylab, 0),`	2618	`SEXP xl = STRING_ELT(xlab, 0), yl = STRING_ELT(ylab, 0),`
2619	`zl = STRING_ELT(zlab, 0);`	2619	`zl = STRING_ELT(zlab, 0);`
2620	`PerspAxes(REAL(xlim), REAL(ylim), REAL(zlim),`	2620	`PerspAxes(REAL(xlim), REAL(ylim), REAL(zlim),`
2621	`(xl == NA_STRING)? "" : CHAR(xl),`	2621	`(xl == NA_STRING)? "" : CHAR(xl),`
2622	`(yl == NA_STRING)? "" : CHAR(yl),`	2622	`(yl == NA_STRING)? "" : CHAR(yl),`
2623	`(zl == NA_STRING)? "" : CHAR(zl),`	2623	`(zl == NA_STRING)? "" : CHAR(zl),`
2624	`nTicks, tickType, dd);`	2624	`nTicks, tickType, dd);`
2625	`}`	2625	`}`
2626	`}`	2626	`}`

The R Project SVN R

(root)/trunk/src/main/plot3d.c @ 28362 – Rev 30980 → 31216