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



{
/*	Create an  'at = ...' vector for  axis(.) / do_axis,
 *	i.e., the vector of tick mark locations,
 *	when none has been specified (= default).
 *
 *	axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks
 *                 {unless in log case, where nint \in {1,2,3 ; -1,-2,....}
 *                  and the `nint' argument is used.
 
 *	The resulting REAL vector must have length >= 1, ideally >= 2
 */
    SEXP at = R_NilValue;/* -Wall*/
    double umin, umax, dn, rng, small;
    int i, n, ne;
    if (!logflag || axp[2] < 0) { /* --- linear axis --- Only use axp[] arg. */
	n = fabs(axp[2]) + 0.25;/* >= 0 */
	dn = imax2(1, n);
	rng = axp[1] - axp[0];
	small = fabs(rng)/(100.*dn);
	at = allocVector(REALSXP, n + 1);

}
 
SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env)
{
    /* axis(side, at, labels, tick, line, pos,
     *	    outer, font, vfont, lty, lwd, col, ...) */
 
    SEXP at, lab, vfont;
    int col, font, lty;
    int i, n, nint = 0, ntmp, side, *ind, outer;
    int istart, iend, incr;
    Rboolean dolabels, doticks, logflag = FALSE;
    Rboolean create_at, vectorFonts = FALSE;
    double x, y, temp, tnew, tlast;
    double axp[3], usr[2];
    double gap, labw, low, high, line, pos, lwd;
    double axis_base, axis_tick, axis_lab, axis_low, axis_high;
 

    }
 
    /* Determine the tickmark positions.  Note that these may fall */
    /* outside the plot window. We will clip them in the code below. */
 
    create_at = (length(at) == 0);
    if (create_at) {
	PROTECT(at = CreateAtVector(axp, usr, nint, logflag));
    }
    else {
	if (isReal(at)) PROTECT(at = duplicate(at));
	else PROTECT(at = coerceVector(at, REALSXP));

	return R_NilValue;
    }
 
 
    /* no! we do allow an `lty' argument -- will not be used often though
     *	Rf_gpptr(dd)->lty = LTY_SOLID; */
    Rf_gpptr(dd)->lty = lty;
    Rf_gpptr(dd)->lwd = lwd;
 
    /* Override par("xpd") and force clipping to figure region.
     * NOTE: don't override to _reduce_ clipping region */

		+ GConvertY(0.0, NPC, NFC, dd);
	}
	else { /* side == 3 */
	    axis_lab = axis_base
		+ GConvertYUnits(Rf_gpptr(dd)->mgp[1], LINES, NFC, dd)
		- GConvertY(1.0, NPC, NFC, dd);
	}
	axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);
 
	/* The order of processing is important here. */
	/* We must ensure that the labels are drawn left-to-right. */

	    string = STRING_ELT(text, i%ntext);
#ifdef GMV_implemented
	    if(string != NA_STRING)
		GMVText(CHAR(string),
			INTEGER(vfont)[0], INTEGER(vfont)[1],
			sideval, lineval, outerval, atval,
			Rf_gpptr(dd)->las, dd);
#else
	    warningcall(call,"Hershey fonts not yet implemented for mtext()");
	    if(string != NA_STRING)
		GMtext(CHAR(string), sideval, lineval, outerval, atval,
		       Rf_gpptr(dd)->las, dd);
#endif
	}
	else if (isExpression(text))
	    GMMathText(VECTOR_ELT(text, i%ntext),
		       sideval, lineval, outerval, atval, Rf_gpptr(dd)->las, dd);
	else {
	    string = STRING_ELT(text, i%ntext);
	    if(string != NA_STRING)
		GMtext(CHAR(string), sideval, lineval, outerval, atval,
		       Rf_gpptr(dd)->las, dd);
	}
 
	if (outerval == 0) dirtyplot = TRUE;
    }

	  n = length(Main);
	  offset = 0.5 * (n - 1) + vpos;
	  for (i = 0; i < n; i++) {
		string = STRING_ELT(Main, i);
		if(string != NA_STRING)
		    GText(hpos, offset - i, where, CHAR(string), adj,
			  adjy, 0.0, dd);
	  }
	}
    }
    if (sub != R_NilValue) {

		    xx[i] = x[0] + i*xstep;
		    yy[i] = aa + xx[i] * bb;
		}
		xx[100] = x[1];
		yy[100] = aa + x[1] * bb;
 
		/* now get rid of -ve values */
		lstart=0;lstop=100;
		if (Rf_gpptr(dd)->xlog){
			for(;xx[lstart]<=0 && lstart<101;lstart++);
			for(;xx[lstop]<=0 && lstop>0;lstop--);
		}
		if (Rf_gpptr(dd)->ylog){
			for(;yy[lstart]<=0 && lstart<101;lstart++);
			for(;yy[lstop]<=0 && lstop>0;lstop--);
		}
 
 
		GPolyline(lstop-lstart+1, xx+lstart, yy+lstart, USER, dd);
	    }
	    else {
		double x0, x1;
 

	for (i = 0; i < nr; i++) {
	    xx = REAL(x)[i];
	    yy = REAL(y)[i];
	    if (R_FINITE(xx) && R_FINITE(yy)) {
		p0 = REAL(p)[i];	/* width */
		p1 = REAL(p)[i + nr];	/* height */
		p2 = REAL(p)[i + 2 * nr];/* lower whisker */
		p3 = REAL(p)[i + 3 * nr];/* upper whisker */
		p4 = REAL(p)[i + 4 * nr];/* median proport. in [0,1] */
		if (R_FINITE(p0) && R_FINITE(p1) &&
		    R_FINITE(p2) && R_FINITE(p3) && R_FINITE(p4)) {

Rev 21033	Rev 21044
Line 676...	Line 676...
676	`{`	676	`{`
677	`/* Create an 'at = ...' vector for axis(.) / do_axis,`	677	`/* Create an 'at = ...' vector for axis(.) / do_axis,`
678	`* i.e., the vector of tick mark locations,`	678	`* i.e., the vector of tick mark locations,`
679	`* when none has been specified (= default).`	679	`* when none has been specified (= default).`
680	`*`	680	`*`
681	`* axp[0:2] = (x1, x2, nint), where x1..x2 are the extreme tick marks`	681	`* axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks`
-		682	`* {unless in log case, where nint \in {1,2,3 ; -1,-2,....}`
-		683	* and the `nint' argument is used.
682	`*`	684
683	`* The resulting REAL vector must have length >= 1, ideally >= 2`	685	`* The resulting REAL vector must have length >= 1, ideally >= 2`
684	`*/`	686	`*/`
685	`SEXP at = R_NilValue;/* -Wall*/`	687	`SEXP at = R_NilValue;/* -Wall*/`
686	`double umin, umax, dn, rng, small;`	688	`double umin, umax, dn, rng, small;`
687	`int i, n, ne;`	689	`int i, n, ne;`
688	`if (!logflag \|\| axp[2] < 0) { /* ---- linear axis ---- Only use axp[] arg. */`	690	`if (!logflag \|\| axp[2] < 0) { /* --- linear axis --- Only use axp[] arg. */`
689	`n = fabs(axp[2]) + 0.25;/* >= 0 */`	691	`n = fabs(axp[2]) + 0.25;/* >= 0 */`
690	`dn = imax2(1, n);`	692	`dn = imax2(1, n);`
691	`rng = axp[1] - axp[0];`	693	`rng = axp[1] - axp[0];`
692	`small = fabs(rng)/(100.*dn);`	694	`small = fabs(rng)/(100.*dn);`
693	`at = allocVector(REALSXP, n + 1);`	695	`at = allocVector(REALSXP, n + 1);`
Line 805...	Line 807...
805	`}`	807	`}`
806		808
807	`SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env)`	809	`SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env)`
808	`{`	810	`{`
809	`/* axis(side, at, labels, tick, line, pos,`	811	`/* axis(side, at, labels, tick, line, pos,`
810	`* outer, font, vfont, lty, lwd, col, ...) */`	812	`* outer, font, vfont, lty, lwd, col, ...) */`
811		813
812	`SEXP at, lab, vfont;`	814	`SEXP at, lab, vfont;`
813	`int col, font, lty;`	815	`int col, font, lty;`
814	`int i, n, nint = 0, ntmp, side, *ind, outer;`	816	`int i, n, nint = 0, ntmp, side, *ind, outer;`
815	`int istart, iend, incr;`	817	`int istart, iend, incr;`
816	`Rboolean dolabels, doticks, logflag = FALSE;`	818	`Rboolean dolabels, doticks, logflag = FALSE;`
817	`Rboolean vectorFonts = FALSE;`	819	`Rboolean create_at, vectorFonts = FALSE;`
818	`double x, y, temp, tnew, tlast;`	820	`double x, y, temp, tnew, tlast;`
819	`double axp[3], usr[2];`	821	`double axp[3], usr[2];`
820	`double gap, labw, low, high, line, pos, lwd;`	822	`double gap, labw, low, high, line, pos, lwd;`
821	`double axis_base, axis_tick, axis_lab, axis_low, axis_high;`	823	`double axis_base, axis_tick, axis_lab, axis_low, axis_high;`
822		824
Line 953...	Line 955...
953	`}`	955	`}`
954		956
955	`/* Determine the tickmark positions. Note that these may fall */`	957	`/* Determine the tickmark positions. Note that these may fall */`
956	`/* outside the plot window. We will clip them in the code below. */`	958	`/* outside the plot window. We will clip them in the code below. */`
957		959
958	`if (length(at) == 0) {`	960	`create_at = (length(at) == 0);`
-		961	`if (create_at) {`
959	`PROTECT(at = CreateAtVector(axp, usr, nint, logflag));`	962	`PROTECT(at = CreateAtVector(axp, usr, nint, logflag));`
960	`}`	963	`}`
961	`else {`	964	`else {`
962	`if (isReal(at)) PROTECT(at = duplicate(at));`	965	`if (isReal(at)) PROTECT(at = duplicate(at));`
963	`else PROTECT(at = coerceVector(at, REALSXP));`	966	`else PROTECT(at = coerceVector(at, REALSXP));`
Line 1009...	Line 1012...
1009	`return R_NilValue;`	1012	`return R_NilValue;`
1010	`}`	1013	`}`
1011		1014
1012		1015
1013	/* no! we do allow an `lty' argument -- will not be used often though	1016	/* no! we do allow an `lty' argument -- will not be used often though
1014	`* Rf_gpptr(dd)->lty = LTY_SOLID; */`	1017	`* Rf_gpptr(dd)->lty = LTY_SOLID; */`
1015	`Rf_gpptr(dd)->lty = lty;`	1018	`Rf_gpptr(dd)->lty = lty;`
1016	`Rf_gpptr(dd)->lwd = lwd;`	1019	`Rf_gpptr(dd)->lwd = lwd;`
1017		1020
1018	`/* Override par("xpd") and force clipping to figure region.`	1021	`/* Override par("xpd") and force clipping to figure region.`
1019	`* NOTE: don't override to _reduce_ clipping region */`	1022	`* NOTE: don't override to _reduce_ clipping region */`
Line 1082...	Line 1085...
1082	`+ GConvertY(0.0, NPC, NFC, dd);`	1085	`+ GConvertY(0.0, NPC, NFC, dd);`
1083	`}`	1086	`}`
1084	`else { /* side == 3 */`	1087	`else { /* side == 3 */`
1085	`axis_lab = axis_base`	1088	`axis_lab = axis_base`
1086	`+ GConvertYUnits(Rf_gpptr(dd)->mgp[1], LINES, NFC, dd)`	1089	`+ GConvertYUnits(Rf_gpptr(dd)->mgp[1], LINES, NFC, dd)`
1087	`- GConvertY(1.0, NPC, NFC, dd);`	1090	`- GConvertY(1.0, NPC, NFC, dd);`
1088	`}`	1091	`}`
1089	`axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);`	1092	`axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);`
1090		1093
1091	`/* The order of processing is important here. */`	1094	`/* The order of processing is important here. */`
1092	`/* We must ensure that the labels are drawn left-to-right. */`	1095	`/* We must ensure that the labels are drawn left-to-right. */`
Line 2336...	Line 2339...
2336	`string = STRING_ELT(text, i%ntext);`	2339	`string = STRING_ELT(text, i%ntext);`
2337	`#ifdef GMV_implemented`	2340	`#ifdef GMV_implemented`
2338	`if(string != NA_STRING)`	2341	`if(string != NA_STRING)`
2339	`GMVText(CHAR(string),`	2342	`GMVText(CHAR(string),`
2340	`INTEGER(vfont)[0], INTEGER(vfont)[1],`	2343	`INTEGER(vfont)[0], INTEGER(vfont)[1],`
2341	`sideval, lineval, outerval, atval,`	2344	`sideval, lineval, outerval, atval,`
2342	`Rf_gpptr(dd)->las, dd);`	2345	`Rf_gpptr(dd)->las, dd);`
2343	`#else`	2346	`#else`
2344	`warningcall(call,"Hershey fonts not yet implemented for mtext()");`	2347	`warningcall(call,"Hershey fonts not yet implemented for mtext()");`
2345	`if(string != NA_STRING)`	2348	`if(string != NA_STRING)`
2346	`GMtext(CHAR(string), sideval, lineval, outerval, atval,`	2349	`GMtext(CHAR(string), sideval, lineval, outerval, atval,`
2347	`Rf_gpptr(dd)->las, dd);`	2350	`Rf_gpptr(dd)->las, dd);`
2348	`#endif`	2351	`#endif`
2349	`}`	2352	`}`
2350	`else if (isExpression(text))`	2353	`else if (isExpression(text))`
2351	`GMMathText(VECTOR_ELT(text, i%ntext),`	2354	`GMMathText(VECTOR_ELT(text, i%ntext),`
2352	`sideval, lineval, outerval, atval, Rf_gpptr(dd)->las, dd);`	2355	`sideval, lineval, outerval, atval, Rf_gpptr(dd)->las, dd);`
2353	`else {`	2356	`else {`
2354	`string = STRING_ELT(text, i%ntext);`	2357	`string = STRING_ELT(text, i%ntext);`
2355	`if(string != NA_STRING)`	2358	`if(string != NA_STRING)`
2356	`GMtext(CHAR(string), sideval, lineval, outerval, atval,`	2359	`GMtext(CHAR(string), sideval, lineval, outerval, atval,`
2357	`Rf_gpptr(dd)->las, dd);`	2360	`Rf_gpptr(dd)->las, dd);`
2358	`}`	2361	`}`
2359		2362
2360	`if (outerval == 0) dirtyplot = TRUE;`	2363	`if (outerval == 0) dirtyplot = TRUE;`
2361	`}`	2364	`}`
Line 2471...	Line 2474...
2471	`n = length(Main);`	2474	`n = length(Main);`
2472	`offset = 0.5 * (n - 1) + vpos;`	2475	`offset = 0.5 * (n - 1) + vpos;`
2473	`for (i = 0; i < n; i++) {`	2476	`for (i = 0; i < n; i++) {`
2474	`string = STRING_ELT(Main, i);`	2477	`string = STRING_ELT(Main, i);`
2475	`if(string != NA_STRING)`	2478	`if(string != NA_STRING)`
2476	`GText(hpos, offset - i, where, CHAR(string), adj,`	2479	`GText(hpos, offset - i, where, CHAR(string), adj,`
2477	`adjy, 0.0, dd);`	2480	`adjy, 0.0, dd);`
2478	`}`	2481	`}`
2479	`}`	2482	`}`
2480	`}`	2483	`}`
2481	`if (sub != R_NilValue) {`	2484	`if (sub != R_NilValue) {`
Line 2717...	Line 2720...
2717	`xx[i] = x[0] + i*xstep;`	2720	`xx[i] = x[0] + i*xstep;`
2718	`yy[i] = aa + xx[i] * bb;`	2721	`yy[i] = aa + xx[i] * bb;`
2719	`}`	2722	`}`
2720	`xx[100] = x[1];`	2723	`xx[100] = x[1];`
2721	`yy[100] = aa + x[1] * bb;`	2724	`yy[100] = aa + x[1] * bb;`
2722		2725
2723	`/* now get rid of -ve values */`	2726	`/* now get rid of -ve values */`
2724	`lstart=0;lstop=100;`	2727	`lstart=0;lstop=100;`
2725	`if (Rf_gpptr(dd)->xlog){`	2728	`if (Rf_gpptr(dd)->xlog){`
2726	`for(;xx[lstart]<=0 && lstart<101;lstart++);`	2729	`for(;xx[lstart]<=0 && lstart<101;lstart++);`
2727	`for(;xx[lstop]<=0 && lstop>0;lstop--);`	2730	`for(;xx[lstop]<=0 && lstop>0;lstop--);`
2728	`}`	2731	`}`
2729	`if (Rf_gpptr(dd)->ylog){`	2732	`if (Rf_gpptr(dd)->ylog){`
2730	`for(;yy[lstart]<=0 && lstart<101;lstart++);`	2733	`for(;yy[lstart]<=0 && lstart<101;lstart++);`
2731	`for(;yy[lstop]<=0 && lstop>0;lstop--);`	2734	`for(;yy[lstop]<=0 && lstop>0;lstop--);`
2732	`}`	2735	`}`
2733		2736
2734		2737
2735	`GPolyline(lstop-lstart+1, xx+lstart, yy+lstart, USER, dd);`	2738	`GPolyline(lstop-lstart+1, xx+lstart, yy+lstart, USER, dd);`
2736	`}`	2739	`}`
2737	`else {`	2740	`else {`
2738	`double x0, x1;`	2741	`double x0, x1;`
2739		2742
Line 3794...	Line 3797...
3794	`for (i = 0; i < nr; i++) {`	3797	`for (i = 0; i < nr; i++) {`
3795	`xx = REAL(x)[i];`	3798	`xx = REAL(x)[i];`
3796	`yy = REAL(y)[i];`	3799	`yy = REAL(y)[i];`
3797	`if (R_FINITE(xx) && R_FINITE(yy)) {`	3800	`if (R_FINITE(xx) && R_FINITE(yy)) {`
3798	`p0 = REAL(p)[i]; /* width */`	3801	`p0 = REAL(p)[i]; /* width */`
3799	`p1 = REAL(p)[i + nr]; /* height */`	3802	`p1 = REAL(p)[i + nr]; /* height */`
3800	`p2 = REAL(p)[i + 2 * nr];/* lower whisker */`	3803	`p2 = REAL(p)[i + 2 * nr];/* lower whisker */`
3801	`p3 = REAL(p)[i + 3 * nr];/* upper whisker */`	3804	`p3 = REAL(p)[i + 3 * nr];/* upper whisker */`
3802	`p4 = REAL(p)[i + 4 * nr];/* median proport. in [0,1] */`	3805	`p4 = REAL(p)[i + 4 * nr];/* median proport. in [0,1] */`
3803	`if (R_FINITE(p0) && R_FINITE(p1) &&`	3806	`if (R_FINITE(p0) && R_FINITE(p1) &&`
3804	`R_FINITE(p2) && R_FINITE(p3) && R_FINITE(p4)) {`	3807	`R_FINITE(p2) && R_FINITE(p3) && R_FINITE(p4)) {`

The R Project SVN R

(root)/trunk/src/main/plot.c @ 28362 – Rev 21033 → 21044