The R Project SVN R

Rev

Rev 59266 | Rev 59276 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 59266 Rev 59267
Line 29... Line 29...
29 
#include <Colors.h> /* for isNAcol */
 29 
#include <Colors.h> /* for isNAcol */
30 
#include <Print.h>
 30 
#include <Print.h>
31 
 
 31 
 
32 
#define imax2(x, y) ((x < y) ? y : x)
 32 
#define imax2(x, y) ((x < y) ? y : x)
33 
 
 33 
 
34 
/*  P A R A M E T E R	 U T I L I T I E S  */
 - 
 
35 
 
 - 
 
36 
/* used on do_contour, graphics/src */
 - 
 
37 
attribute_hidden
 - 
 
38 
SEXP FixupLty(SEXP lty, int dflt)
 - 
 
39 
{
 - 
 
40 
    int i, n;
 - 
 
41 
    SEXP ans;
 - 
 
42 
    n = length(lty);
 - 
 
43 
    if (n == 0) {
 - 
 
44 
	ans = ScalarInteger(dflt);
 - 
 
45 
    }
 - 
 
46 
    else {
 - 
 
47 
	ans = allocVector(INTSXP, n);
 - 
 
48 
	for (i = 0; i < n; i++)
 - 
 
49 
	    INTEGER(ans)[i] = GE_LTYpar(lty, i);
 - 
 
50 
    }
 - 
 
51 
    return ans;
 - 
 
52 
}
 - 
 
53 
 
 - 
 
54 
attribute_hidden
 - 
 
55 
SEXP FixupLwd(SEXP lwd, double dflt)
 - 
 
56 
{
 - 
 
57 
    int i, n;
 - 
 
58 
    double w;
 - 
 
59 
    SEXP ans = NULL;
 - 
 
60 
 
 - 
 
61 
    n = length(lwd);
 - 
 
62 
    if (n == 0)
 - 
 
63 
	ans = ScalarReal(dflt);
 - 
 
64 
    else {
 - 
 
65 
	PROTECT(lwd = coerceVector(lwd, REALSXP));
 - 
 
66 
	n = length(lwd);
 - 
 
67 
	ans = allocVector(REALSXP, n);
 - 
 
68 
	for (i = 0; i < n; i++) {
 - 
 
69 
	    w = REAL(lwd)[i];
 - 
 
70 
	    if (w < 0) w = NA_REAL;
 - 
 
71 
	    REAL(ans)[i] = w;
 - 
 
72 
 
 - 
 
73 
	}
 - 
 
74 
	UNPROTECT(1);
 - 
 
75 
    }
 - 
 
76 
    return ans;
 - 
 
77 
}
 - 
 
78 
 
 - 
 
79 
 
 - 
 
80 
SEXP FixupCol(SEXP col, unsigned int dflt)
 - 
 
81 
{
 - 
 
82 
    int i, n;
 - 
 
83 
    SEXP ans;
 - 
 
84 
    unsigned int bg = dpptr(GEcurrentDevice())->bg; /* col = 0 */
 - 
 
85 
 
 - 
 
86 
    n = length(col);
 - 
 
87 
    if (n == 0) {
 - 
 
88 
	PROTECT(ans = ScalarInteger(dflt));
 - 
 
89 
    } else {
 - 
 
90 
	ans = PROTECT(allocVector(INTSXP, n));
 - 
 
91 
	if (isList(col))
 - 
 
92 
	    for (i = 0; i < n; i++) {
 - 
 
93 
		INTEGER(ans)[i] = RGBpar3(CAR(col), 0, bg);
 - 
 
94 
		col = CDR(col);
 - 
 
95 
	    }
 - 
 
96 
	else
 - 
 
97 
	    for (i = 0; i < n; i++)
 - 
 
98 
		INTEGER(ans)[i] = RGBpar3(col, i, bg);
 - 
 
99 
    }
 - 
 
100 
    UNPROTECT(1);
 - 
 
101 
    return ans;
 - 
 
102 
}
 - 
 
103 
 
 - 
 
104 
 
 - 
 
105 
attribute_hidden
 - 
 
106 
SEXP FixupVFont(SEXP vfont) {
 - 
 
107 
    SEXP ans = R_NilValue;
 - 
 
108 
    if (!isNull(vfont)) {
 - 
 
109 
	SEXP vf;
 - 
 
110 
	int typeface, fontindex;
 - 
 
111 
	int minindex, maxindex=0;/* -Wall*/
 - 
 
112 
	int i;
 - 
 
113 
	PROTECT(vf = coerceVector(vfont, INTSXP));
 - 
 
114 
	if (length(vf) != 2)
 - 
 
115 
	    error(_("invalid '%s' value"), "vfont");
 - 
 
116 
	typeface = INTEGER(vf)[0];
 - 
 
117 
	if (typeface < 1 || typeface > 8)
 - 
 
118 
	    error(_("invalid 'vfont' value [typeface]"));
 - 
 
119 
	/* For each of the typefaces {1..8}, there are several fontindices
 - 
 
120 
	   available; how many depends on the typeface.
 - 
 
121 
	   The possible combinations are "given" in ./g_fontdb.c
 - 
 
122 
	   and also listed in help(Hershey).
 - 
 
123 
	 */
 - 
 
124 
	minindex = 1;
 - 
 
125 
	switch (typeface) {
 - 
 
126 
	case 1: /* serif */
 - 
 
127 
	    maxindex = 7;	    break;
 - 
 
128 
	case 2: /* sans serif */
 - 
 
129 
	case 7: /* serif symbol */
 - 
 
130 
	    maxindex = 4;	    break;
 - 
 
131 
	case 3: /* script */
 - 
 
132 
	    maxindex = 3;	    break;
 - 
 
133 
	case 4: /* gothic english */
 - 
 
134 
	case 5: /* gothic german */
 - 
 
135 
	case 6: /* gothic italian */
 - 
 
136 
	    maxindex = 1;	    break;
 - 
 
137 
	case 8: /* sans serif symbol */
 - 
 
138 
	    maxindex = 2;
 - 
 
139 
	}
 - 
 
140 
	fontindex = INTEGER(vf)[1];
 - 
 
141 
	if (fontindex < minindex || fontindex > maxindex)
 - 
 
142 
	    error(_("invalid 'vfont' value [typeface = %d, fontindex = %d]"),
 - 
 
143 
		  typeface, fontindex);
 - 
 
144 
	ans = allocVector(INTSXP, 2);
 - 
 
145 
	for (i = 0; i < 2; i++) INTEGER(ans)[i] = INTEGER(vf)[i];
 - 
 
146 
	UNPROTECT(1);
 - 
 
147 
    }
 - 
 
148 
    return ans;
 - 
 
149 
}
 - 
 
150 
 
 - 
 
151 
/* used in graphics and grid */
 34 
/* used in graphics and grid */
152 
SEXP CreateAtVector(double *axp, double *usr, int nint, Rboolean logflag)
 35 
SEXP CreateAtVector(double *axp, double *usr, int nint, Rboolean logflag)
153 
{
 36 
{
154 
/*	Create an  'at = ...' vector for  axis(.)
 37 
/*	Create an  'at = ...' vector for  axis(.)
155 
 *	i.e., the vector of tick mark locations,
 38 
 *	i.e., the vector of tick mark locations,
Line 314... Line 197...
314 
	}
 197 
	}
315 
    } /* linear / log */
 198 
    } /* linear / log */
316 
    return at;
 199 
    return at;
317 
}
 200 
}
318 
 
 201 
 
319 
/* in Graphics.h, used in contour and in graphics/src */
 - 
 
320 
SEXP labelformat(SEXP labels)
 - 
 
321 
{
 - 
 
322 
    /* format(labels): i.e. from numbers to strings */
 - 
 
323 
    SEXP ans = R_NilValue;/* -Wall*/
 - 
 
324 
    int i, n, w, d, e, wi, di, ei;
 - 
 
325 
    const char *strp;
 - 
 
326 
    n = length(labels);
 - 
 
327 
    R_print.digits = 7;/* maximally 7 digits -- ``burnt in'';
 - 
 
328 
			  S-PLUS <= 5.x has about 6
 - 
 
329 
			  (but really uses single precision..) */
 - 
 
330 
    switch(TYPEOF(labels)) {
 - 
 
331 
    case LGLSXP:
 - 
 
332 
	PROTECT(ans = allocVector(STRSXP, n));
 - 
 
333 
	for (i = 0; i < n; i++) {
 - 
 
334 
	    strp = EncodeLogical(LOGICAL(labels)[i], 0);
 - 
 
335 
	    SET_STRING_ELT(ans, i, mkChar(strp));
 - 
 
336 
	}
 - 
 
337 
	UNPROTECT(1);
 - 
 
338 
	break;
 - 
 
339 
    case INTSXP:
 - 
 
340 
	PROTECT(ans = allocVector(STRSXP, n));
 - 
 
341 
	for (i = 0; i < n; i++) {
 - 
 
342 
	    strp = EncodeInteger(INTEGER(labels)[i], 0);
 - 
 
343 
	    SET_STRING_ELT(ans, i, mkChar(strp));
 - 
 
344 
	}
 - 
 
345 
	UNPROTECT(1);
 - 
 
346 
	break;
 - 
 
347 
    case REALSXP:
 - 
 
348 
	formatReal(REAL(labels), n, &w, &d, &e, 0);
 - 
 
349 
	PROTECT(ans = allocVector(STRSXP, n));
 - 
 
350 
	for (i = 0; i < n; i++) {
 - 
 
351 
	    strp = EncodeReal(REAL(labels)[i], 0, d, e, OutDec);
 - 
 
352 
	    SET_STRING_ELT(ans, i, mkChar(strp));
 - 
 
353 
	}
 - 
 
354 
	UNPROTECT(1);
 - 
 
355 
	break;
 - 
 
356 
    case CPLXSXP:
 - 
 
357 
	formatComplex(COMPLEX(labels), n, &w, &d, &e, &wi, &di, &ei, 0);
 - 
 
358 
	PROTECT(ans = allocVector(STRSXP, n));
 - 
 
359 
	for (i = 0; i < n; i++) {
 - 
 
360 
	    strp = EncodeComplex(COMPLEX(labels)[i], 0, d, e, 0, di, ei,
 - 
 
361 
				 OutDec);
 - 
 
362 
	    SET_STRING_ELT(ans, i, mkChar(strp));
 - 
 
363 
	}
 - 
 
364 
	UNPROTECT(1);
 - 
 
365 
	break;
 - 
 
366 
    case STRSXP:
 - 
 
367 
	PROTECT(ans = allocVector(STRSXP, n));
 - 
 
368 
	for (i = 0; i < n; i++) {
 - 
 
369 
	    SET_STRING_ELT(ans, i, STRING_ELT(labels, i));
 - 
 
370 
	}
 - 
 
371 
	UNPROTECT(1);
 - 
 
372 
	break;
 - 
 
373 
    default:
 - 
 
374 
	error(_("invalid type for axis labels"));
 - 
 
375 
    }
 - 
 
376 
    return ans;
 - 
 
377 
}
 - 
 
378 
 
 - 
 
379 
 
 - 
 
380 
    /* GRAPHICS FUNCTION ENTRY POINTS */
 202 
    /* GRAPHICS FUNCTION ENTRY POINTS */
381 
 
 203 
 
382 
 
 204 
 
383 
SEXP attribute_hidden do_plot_new(SEXP call, SEXP op, SEXP args, SEXP env)
 205 
SEXP attribute_hidden do_plot_new(SEXP call, SEXP op, SEXP args, SEXP env)
384 
{
 206 
{