The R Project SVN R

Rev

Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
564 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
26479 maechler 4 
 *  Copyright (C) 1997--2001  Robert Gentleman, Ross Ihaka and the
16482 maechler 5 
 *			      R Development Core Team
30691 murdoch 6 
 *  Copyright (C) 2002--2004  The R Foundation
2 r 7 
 *
8 
 *  This program is free software; you can redistribute it and/or modify
9 
 *  it under the terms of the GNU General Public License as published by
10 
 *  the Free Software Foundation; either version 2 of the License, or
11 
 *  (at your option) any later version.
12 
 *
13 
 *  This program is distributed in the hope that it will be useful,
14 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
15 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 
 *  GNU General Public License for more details.
17 
 *
26479 maechler 18 
 *  A copy of the GNU General Public License is available via WWW at
19 
 *  http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
20 
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
21 
 *  Suite 330, Boston, MA  02111-1307  USA.
2 r 22 
 */
23 
 
5187 hornik 24 
#ifdef HAVE_CONFIG_H
7701 hornik 25 
#include <config.h>
5187 hornik 26 
#endif
27 
 
11499 ripley 28 
#include <Defn.h>
29 
#include <Rmath.h>
30 
#include <Graphics.h>
12778 pd 31 
#include <Rdevices.h>
11499 ripley 32 
#include <Print.h>
2 r 33 
 
9417 ripley 34 
#ifndef HAVE_HYPOT
35 
# define hypot pythag
36 
#endif
37 
 
38 
 
10886 maechler 39 
void NewFrameConfirm(void)
2 r 40 
{
7081 pd 41 
    unsigned char buf[16];
648 ihaka 42 
    R_ReadConsole("Hit <Return> to see next plot: ", buf, 16, 0);
2 r 43 
}
44 
 
648 ihaka 45 
	/* Remember: +1 and/or -1 because C arrays are */
46 
	/* zero-based and R-vectors are one-based. */
2 r 47 
 
6098 pd 48 
#define checkArity_length					\
49 
    checkArity(op, args);					\
50 
    if(!LENGTH(CAR(args)))					\
6191 maechler 51 
	errorcall(call, "argument must have positive length")
6098 pd 52 
 
53 
 
581 paul 54 
SEXP do_devcontrol(SEXP call, SEXP op, SEXP args, SEXP env)
55 
{
25661 ripley 56 
    int listFlag;
26479 maechler 57 
 
648 ihaka 58 
    checkArity(op, args);
25661 ripley 59 
    listFlag = asLogical(CAR(args));
60 
    if(listFlag == NA_LOGICAL) errorcall(call, "invalid argument");
61 
    if(listFlag)
62 
	enableDisplayList(CurrentDevice());
63 
    else
64 
	inhibitDisplayList(CurrentDevice());
65 
    return ScalarLogical(listFlag);
2 r 66 
}
67 
 
581 paul 68 
SEXP do_devcopy(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 69 
{
6098 pd 70 
    checkArity_length;
17113 murrell 71 
    GEcopyDisplayList(INTEGER(CAR(args))[0] - 1);
648 ihaka 72 
    return R_NilValue;
2 r 73 
}
74 
 
581 paul 75 
SEXP do_devcur(SEXP call, SEXP op, SEXP args, SEXP env)
76 
{
648 ihaka 77 
    SEXP cd = allocVector(INTSXP, 1);
78 
    checkArity(op, args);
79 
    INTEGER(cd)[0] = curDevice() + 1;
80 
    return cd;
581 paul 81 
}
2 r 82 
 
581 paul 83 
SEXP do_devnext(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 84 
{
648 ihaka 85 
    SEXP nd = allocVector(INTSXP, 1);
6098 pd 86 
    checkArity_length;
87 
    INTEGER(nd)[0] = nextDevice(INTEGER(CAR(args))[0] - 1) + 1;
648 ihaka 88 
    return nd;
2 r 89 
}
90 
 
581 paul 91 
SEXP do_devprev(SEXP call, SEXP op, SEXP args, SEXP env)
92 
{
648 ihaka 93 
    SEXP pd = allocVector(INTSXP, 1);
6098 pd 94 
    checkArity_length;
95 
    INTEGER(pd)[0] = prevDevice(INTEGER(CAR(args))[0] - 1) + 1;
648 ihaka 96 
    return pd;
581 paul 97 
}
98 
 
99 
SEXP do_devset(SEXP call, SEXP op, SEXP args, SEXP env)
100 
{
5507 ihaka 101 
    int devNum = INTEGER(CAR(args))[0] - 1;
102 
    SEXP sd = allocVector(INTSXP, 1);
103 
    checkArity(op, args);
104 
    INTEGER(sd)[0] = selectDevice(devNum) + 1;
105 
    return sd;
581 paul 106 
}
107 
 
108 
SEXP do_devoff(SEXP call, SEXP op, SEXP args, SEXP env)
109 
{
6098 pd 110 
    checkArity_length;
648 ihaka 111 
    killDevice(INTEGER(CAR(args))[0] - 1);
112 
    return R_NilValue;
581 paul 113 
}
114 
 
600 ihaka 115 
 
2666 maechler 116 
/*  P A R A M E T E R	 U T I L I T I E S  */
648 ihaka 117 
 
118 
 
2666 maechler 119 
/* ProcessInLinePars handles inline par specifications in graphics functions.
2690 maechler 120 
 * It does this by calling Specify2() from ./par.c */
1839 ihaka 121 
 
19912 duncan 122 
void ProcessInlinePars(SEXP s, DevDesc *dd, SEXP call)
600 ihaka 123 
{
5507 ihaka 124 
    if (isList(s)) {
125 
	while (s != R_NilValue) {
126 
	    if (isList(CAR(s)))
19912 duncan 127 
		ProcessInlinePars(CAR(s), dd, call);
5507 ihaka 128 
	    else if (TAG(s) != R_NilValue)
19936 maechler 129 
	    Specify2(CHAR(PRINTNAME(TAG(s))), CAR(s), dd, call);
648 ihaka 130 
	    s = CDR(s);
600 ihaka 131 
	}
648 ihaka 132 
    }
600 ihaka 133 
}
134 
 
30691 murdoch 135 
/*
136 
 * Extract specified par from list of inline pars
137 
 */
138 
SEXP getInlinePar(SEXP s, char *name)
139 
{
140 
    SEXP result = R_NilValue;
141 
    int found = 0;
142 
    if (isList(s) && !found) {
143 
	while (s != R_NilValue) {
144 
	    if (isList(CAR(s))) {
145 
		result = getInlinePar(CAR(s), name);
146 
		if (result)
147 
		    found = 1;
148 
	    } else
149 
		if (TAG(s) != R_NilValue)
150 
		    if (!strcmp(CHAR(PRINTNAME(TAG(s))), name)) {
151 
			result = CAR(s);
152 
			found = 1;
153 
		    }
154 
	    s = CDR(s);
155 
	}
156 
    }
157 
    return result;
158 
}
159 
 
5507 ihaka 160 
SEXP FixupPch(SEXP pch, int dflt)
2 r 161 
{
648 ihaka 162 
    int i, n;
987 maechler 163 
    SEXP ans = R_NilValue;/* -Wall*/
2 r 164 
 
987 maechler 165 
    n = length(pch);
5491 ihaka 166 
    if (n == 0) {
167 
	ans = allocVector(INTSXP, 1);
5507 ihaka 168 
	INTEGER(ans)[0] = dflt;
648 ihaka 169 
    }
5491 ihaka 170 
    else if (isList(pch)) {
171 
	ans = allocVector(INTSXP, n);
16482 maechler 172 
	for (i = 0; pch != R_NilValue;	pch = CDR(pch))
648 ihaka 173 
	    INTEGER(ans)[i++] = asInteger(CAR(pch));
174 
    }
5491 ihaka 175 
    else if (isInteger(pch)) {
176 
	ans = allocVector(INTSXP, n);
177 
	for (i = 0; i < n; i++)
648 ihaka 178 
	    INTEGER(ans)[i] = INTEGER(pch)[i];
179 
    }
5491 ihaka 180 
    else if (isReal(pch)) {
181 
	ans = allocVector(INTSXP, n);
182 
	for (i = 0; i < n; i++)
5107 maechler 183 
	    INTEGER(ans)[i] = R_FINITE(REAL(pch)[i]) ?
648 ihaka 184 
		REAL(pch)[i] : NA_INTEGER;
185 
    }
5491 ihaka 186 
    else if (isString(pch)) {
187 
	ans = allocVector(INTSXP, n);
188 
	for (i = 0; i < n; i++)
29381 maechler 189 
	    INTEGER(ans)[i] = STRING_ELT(pch, i) != NA_STRING ?
190 
		CHAR(STRING_ELT(pch, i))[0] : NA_INTEGER;
648 ihaka 191 
    }
29381 maechler 192 
    else if (isLogical(pch)) {/* NA, but not TRUE/FALSE */
193 
	ans = allocVector(INTSXP, n);
194 
	for (i = 0; i < n; i++)
195 
	    if(LOGICAL(pch)[i] == NA_LOGICAL)
196 
		INTEGER(ans)[i] = NA_INTEGER;
197 
	    else error("only NA allowed in logical plotting symbol");
198 
    }
6191 maechler 199 
    else error("invalid plotting symbol");
5491 ihaka 200 
    for (i = 0; i < n; i++) {
6994 pd 201 
	if (INTEGER(ans)[i] < 0 && INTEGER(ans)[i] != NA_INTEGER)
5507 ihaka 202 
	    INTEGER(ans)[i] = dflt;
648 ihaka 203 
    }
204 
    return ans;
2 r 205 
}
206 
 
5507 ihaka 207 
SEXP FixupLty(SEXP lty, int dflt)
2 r 208 
{
648 ihaka 209 
    int i, n;
210 
    SEXP ans;
5491 ihaka 211 
    n = length(lty);
212 
    if (n == 0) {
648 ihaka 213 
	ans = allocVector(INTSXP, 1);
5507 ihaka 214 
	INTEGER(ans)[0] = dflt;
648 ihaka 215 
    }
216 
    else {
5491 ihaka 217 
	ans = allocVector(INTSXP, n);
218 
	for (i = 0; i < n; i++)
648 ihaka 219 
	    INTEGER(ans)[i] = LTYpar(lty, i);
220 
    }
221 
    return ans;
2 r 222 
}
223 
 
5507 ihaka 224 
SEXP FixupLwd(SEXP lwd, double dflt)
5491 ihaka 225 
{
226 
    int i, n;
227 
    double w;
228 
    SEXP ans = NULL;
229 
 
230 
    n = length(lwd);
231 
    if (n == 0) {
16482 maechler 232 
	ans = allocVector(REALSXP, 1);
233 
	REAL(ans)[0] = dflt;
5491 ihaka 234 
    }
235 
    else {
236 
	PROTECT(lwd = coerceVector(lwd, REALSXP));
237 
	n = length(lwd);
16482 maechler 238 
	ans = allocVector(REALSXP, n);
239 
	for (i = 0; i < n; i++) {
240 
	    w = REAL(lwd)[i];
5491 ihaka 241 
	    if (w < 0) w = NA_REAL;
16482 maechler 242 
	    REAL(ans)[i] = w;
5491 ihaka 243 
 
244 
	}
245 
	UNPROTECT(1);
246 
    }
247 
    return ans;
248 
}
249 
 
5507 ihaka 250 
SEXP FixupFont(SEXP font, int dflt)
2 r 251 
{
648 ihaka 252 
    int i, k, n;
987 maechler 253 
    SEXP ans = R_NilValue;/* -Wall*/
5491 ihaka 254 
    n = length(font);
255 
    if (n == 0) {
648 ihaka 256 
	ans = allocVector(INTSXP, 1);
5507 ihaka 257 
	INTEGER(ans)[0] = dflt;
648 ihaka 258 
    }
5507 ihaka 259 
    else if (isInteger(font) || isLogical(font)) {
5491 ihaka 260 
	ans = allocVector(INTSXP, n);
261 
	for (i = 0; i < n; i++) {
648 ihaka 262 
	    k = INTEGER(font)[i];
7081 pd 263 
#ifndef Win32
5507 ihaka 264 
	    if (k < 1 || k > 4) k = NA_INTEGER;
7081 pd 265 
#else
266 
	    if (k < 1 || k > 32) k = NA_INTEGER;
267 
#endif
648 ihaka 268 
	    INTEGER(ans)[i] = k;
2 r 269 
	}
648 ihaka 270 
    }
5491 ihaka 271 
    else if (isReal(font)) {
272 
	ans = allocVector(INTSXP, n);
273 
	for (i = 0; i < n; i++) {
648 ihaka 274 
	    k = REAL(font)[i];
7081 pd 275 
#ifndef Win32
5491 ihaka 276 
	    if (k < 1 || k > 4) k = NA_INTEGER;
7081 pd 277 
#else
278 
	    if (k < 1 || k > 32) k = NA_INTEGER;
279 
#endif
648 ihaka 280 
	    INTEGER(ans)[i] = k;
2 r 281 
	}
648 ihaka 282 
    }
5731 ripley 283 
    else error("invalid font specification");
648 ihaka 284 
    return ans;
2 r 285 
}
286 
 
5508 ihaka 287 
SEXP FixupCol(SEXP col, unsigned int dflt)
2 r 288 
{
648 ihaka 289 
    int i, n;
290 
    SEXP ans;
5491 ihaka 291 
    n = length(col);
16482 maechler 292 
    if (n == 0) {
648 ihaka 293 
	ans = allocVector(INTSXP, 1);
5507 ihaka 294 
	INTEGER(ans)[0] = dflt;
648 ihaka 295 
    }
296 
    else {
5491 ihaka 297 
	ans = allocVector(INTSXP, n);
16482 maechler 298 
	if (isList(col))
299 
	    for (i = 0; i < n; i++) {
300 
		INTEGER(ans)[i] = RGBpar(CAR(col), 0);
301 
		col = CDR(col);
302 
	    }
303 
	else
304 
	    for (i = 0; i < n; i++)
305 
		INTEGER(ans)[i] = RGBpar(col, i);
648 ihaka 306 
    }
307 
    return ans;
2 r 308 
}
309 
 
5507 ihaka 310 
SEXP FixupCex(SEXP cex, double dflt)
2 r 311 
{
16482 maechler 312 
    SEXP ans;
648 ihaka 313 
    int i, n;
5491 ihaka 314 
    n = length(cex);
16482 maechler 315 
    if (n == 0) {
648 ihaka 316 
	ans = allocVector(REALSXP, 1);
5507 ihaka 317 
	if (R_FINITE(dflt) && dflt > 0)
318 
	    REAL(ans)[0] = dflt;
319 
	else
320 
	    REAL(ans)[0] = NA_REAL;
648 ihaka 321 
    }
16482 maechler 322 
    else {
323 
	double c;
5491 ihaka 324 
	ans = allocVector(REALSXP, n);
16482 maechler 325 
	if (isReal(cex))
326 
	    for (i = 0; i < n; i++) {
327 
		c = REAL(cex)[i];
328 
		if (R_FINITE(c) && c > 0)
329 
		    REAL(ans)[i] = c;
330 
		else
331 
		    REAL(ans)[i] = NA_REAL;
332 
	    }
333 
	else if (isInteger(cex) || isLogical(cex))
334 
 
335 
	    for (i = 0; i < n; i++) {
336 
		c = INTEGER(cex)[i];
337 
		if (c == NA_INTEGER || c <= 0)
338 
		    c = NA_REAL;
648 ihaka 339 
		REAL(ans)[i] = c;
16482 maechler 340 
	    }
648 ihaka 341 
    }
342 
    return ans;
2 r 343 
}
344 
 
7812 murrell 345 
SEXP FixupVFont(SEXP vfont) {
10886 maechler 346 
    SEXP ans = R_NilValue;
347 
    if (!isNull(vfont)) {
7812 murrell 348 
	SEXP vf;
349 
	int typeface, fontindex;
7824 ripley 350 
	int minindex, maxindex=0;/* -Wall*/
7812 murrell 351 
	int i;
352 
	PROTECT(vf = coerceVector(vfont, INTSXP));
353 
	if (length(vf) != 2)
354 
	    error("Invalid vfont value");
355 
	typeface = INTEGER(vf)[0];
356 
	if (typeface < 0 || typeface > 7)
10886 maechler 357 
	    error("Invalid vfont value [typeface]");
11725 maechler 358 
	/* For each of the typefaces {0..7}, there are several fontindices
359 
	   available; how many depends on the typeface.
360 
	   The possible combinations are "given" in ./g_fontdb.c
361 
	   and also listed in help(Hershey).
362 
	 */
363 
	minindex = 1;
7812 murrell 364 
	switch (typeface) {
10886 maechler 365 
	case 0: /* serif */
11725 maechler 366 
	    maxindex = 7;	    break;
10886 maechler 367 
	case 1: /* sans serif */
368 
	case 6: /* serif symbol */
11725 maechler 369 
	    maxindex = 4;	    break;
10886 maechler 370 
	case 2: /* script */
11725 maechler 371 
	    maxindex = 3;	    break;
10886 maechler 372 
	case 3: /* gothic english */
373 
	case 4: /* gothic german */
374 
	case 5: /* gothic italian */
11725 maechler 375 
	    maxindex = 1;	    break;
10886 maechler 376 
	case 7: /* sans serif symbol */
7812 murrell 377 
	    maxindex = 2;
378 
	}
379 
	fontindex = INTEGER(vf)[1];
380 
	if (fontindex < minindex || fontindex > maxindex)
10886 maechler 381 
	    error("Invalid vfont value [fontindex]");
7812 murrell 382 
	ans = allocVector(INTSXP, 2);
383 
	for (i=0; i<2; i++)
384 
	    INTEGER(ans)[i] = INTEGER(vf)[i];
385 
	UNPROTECT(1);
386 
    }
387 
    return ans;
388 
}
2 r 389 
 
10217 pd 390 
/* GetTextArg() : extract from call and possibly set text arguments
10886 maechler 391 
 *  ("label", col=, cex=, font=, vfont=)
10217 pd 392 
 *
10886 maechler 393 
 * Main purpose: Treat things like  title(main = list("This Title", font= 4))
394 
 *
16482 maechler 395 
 * Called from	do_title()  [only, currently]
10217 pd 396 
 */
10886 maechler 397 
static void
398 
GetTextArg(SEXP call, SEXP spec, SEXP *ptxt,
399 
	   int *pcol, double *pcex, int *pfont, SEXP *pvfont)
9291 ihaka 400 
{
30691 murdoch 401 
    int i, n, col, font, colspecd;
9291 ihaka 402 
    double cex;
10886 maechler 403 
    SEXP txt, vfont, nms;
9291 ihaka 404 
 
16482 maechler 405 
    txt	  = R_NilValue;
10886 maechler 406 
    vfont = R_NilValue;
16482 maechler 407 
    cex	  = NA_REAL;
408 
    col	  = NA_INTEGER;
30691 murdoch 409 
    colspecd = 0;
9291 ihaka 410 
    font  = NA_INTEGER;
411 
    PROTECT(txt);
412 
 
413 
    switch (TYPEOF(spec)) {
414 
    case LANGSXP:
10217 pd 415 
    case SYMSXP:
9291 ihaka 416 
	UNPROTECT(1);
417 
	PROTECT(txt = coerceVector(spec, EXPRSXP));
418 
	break;
419 
    case VECSXP:
420 
	if (length(spec) == 0) {
421 
	    *ptxt = R_NilValue;
422 
	}
423 
	else {
424 
	    nms = getAttrib(spec, R_NamesSymbol);
21033 tlumley 425 
	    if (nms==R_NilValue){ /* PR#1939 */
426 
	       txt = VECTOR_ELT(spec, 0);
427 
	       if (TYPEOF(txt) == LANGSXP ||TYPEOF(txt) == SYMSXP ) {
428 
		    UNPROTECT(1);
429 
		    PROTECT(txt = coerceVector(txt, EXPRSXP));
430 
	       }
431 
	       else if (!isExpression(txt)) {
432 
		    UNPROTECT(1);
433 
		    PROTECT(txt = coerceVector(txt, STRSXP));
26479 maechler 434 
	       }
21033 tlumley 435 
	    } else {
436 
	       n = length(nms);
437 
	       for (i = 0; i < n; i++) {
10172 luke 438 
		if (!strcmp(CHAR(STRING_ELT(nms, i)), "cex")) {
439 
		    cex = asReal(VECTOR_ELT(spec, i));
9291 ihaka 440 
		}
10172 luke 441 
		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "col")) {
30691 murdoch 442 
		    SEXP colsxp = VECTOR_ELT(spec, i);
443 
		    if (!isNAcol(colsxp, 0, LENGTH(colsxp))) {
444 
			col = asInteger(FixupCol(colsxp, NA_INTEGER));
445 
			colspecd = 1;
446 
		    }
9291 ihaka 447 
		}
10172 luke 448 
		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "font")) {
449 
		    font = asInteger(FixupFont(VECTOR_ELT(spec, i), NA_INTEGER));
9291 ihaka 450 
		}
10172 luke 451 
		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "vfont")) {
10886 maechler 452 
		    vfont = FixupVFont(VECTOR_ELT(spec, i));
9291 ihaka 453 
		}
10172 luke 454 
		else if (!strcmp(CHAR(STRING_ELT(nms, i)), "")) {
455 
		    txt = VECTOR_ELT(spec, i);
21054 tlumley 456 
		    if (TYPEOF(txt) == LANGSXP || TYPEOF(txt)==SYMSXP) {
16482 maechler 457 
			UNPROTECT(1);
458 
			PROTECT(txt = coerceVector(txt, EXPRSXP));
459 
		    }
9291 ihaka 460 
		    else if (!isExpression(txt)) {
461 
			UNPROTECT(1);
462 
			PROTECT(txt = coerceVector(txt, STRSXP));
463 
		    }
464 
		}
465 
		else errorcall(call, "invalid graphics parameter");
21033 tlumley 466 
	       }
9291 ihaka 467 
	    }
468 
	}
469 
	break;
470 
    case STRSXP:
471 
    case EXPRSXP:
472 
	txt = spec;
473 
	break;
474 
    default:
475 
	txt = coerceVector(spec, STRSXP);
476 
	break;
477 
    }
478 
    UNPROTECT(1);
479 
    if (txt != R_NilValue) {
9318 maechler 480 
	*ptxt = txt;
16482 maechler 481 
	if (R_FINITE(cex))	 *pcex	 = cex;
30691 murdoch 482 
	if (colspecd)	         *pcol	 = col;
16482 maechler 483 
	if (font != NA_INTEGER)	 *pfont	 = font;
10886 maechler 484 
	if (vfont != R_NilValue) *pvfont = vfont;
9291 ihaka 485 
    }
10886 maechler 486 
}/* GetTextArg */
9291 ihaka 487 
 
488 
 
746 ihaka 489 
    /* GRAPHICS FUNCTION ENTRY POINTS */
648 ihaka 490 
 
491 
 
2 r 492 
SEXP do_plot_new(SEXP call, SEXP op, SEXP args, SEXP env)
493 
{
11112 maechler 494 
    /* plot.new() - create a new plot "frame" */
11067 maechler 495 
 
969 ihaka 496 
    DevDesc *dd;
581 paul 497 
 
648 ihaka 498 
    checkArity(op, args);
581 paul 499 
 
11112 maechler 500 
    dd = GNewPlot(GRecording(call));
969 ihaka 501 
 
17179 murrell 502 
    Rf_dpptr(dd)->xlog = Rf_gpptr(dd)->xlog = FALSE;
503 
    Rf_dpptr(dd)->ylog = Rf_gpptr(dd)->ylog = FALSE;
581 paul 504 
 
648 ihaka 505 
    GScale(0.0, 1.0, 1, dd);
506 
    GScale(0.0, 1.0, 2, dd);
507 
    GMapWin2Fig(dd);
783 maechler 508 
    GSetState(1, dd);
581 paul 509 
 
11067 maechler 510 
    if (GRecording(call))
648 ihaka 511 
	recordGraphicOperation(op, args, dd);
512 
    return R_NilValue;
2 r 513 
}
514 
 
515 
 
658 ihaka 516 
/*
517 
 *  SYNOPSIS
518 
 *
2666 maechler 519 
 *	plot.window(xlim, ylim, log="", asp=NA)
658 ihaka 520 
 *
521 
 *  DESCRIPTION
522 
 *
2666 maechler 523 
 *	This function sets up the world coordinates for a graphics
524 
 *	window.	 Note that if asp is a finite positive value then
525 
 *	the window is set up so that one data unit in the y direction
3049 r 526 
 *	is equal in length to one data unit in the x direction divided
527 
 *	by asp.
658 ihaka 528 
 *
2666 maechler 529 
 *	The special case asp == 1 produces plots where distances
3049 r 530 
 *	between points are represented accurately on screen.
658 ihaka 531 
 *
532 
 *  NOTE
533 
 *
2666 maechler 534 
 *	The use of asp can have weird effects when axis is an
535 
 *	interpreted function.  It has to be internal so that the
536 
 *	full computation is captured in the display list.
658 ihaka 537 
 */
2 r 538 
 
539 
SEXP do_plot_window(SEXP call, SEXP op, SEXP args, SEXP env)
540 
{
13046 maechler 541 
    SEXP xlim, ylim, logarg;
658 ihaka 542 
    double asp, xmin, xmax, ymin, ymax;
10886 maechler 543 
    Rboolean logscale;
648 ihaka 544 
    char *p;
545 
    SEXP originalArgs = args;
546 
    DevDesc *dd = CurrentDevice();
2 r 547 
 
5507 ihaka 548 
    if (length(args) < 3)
6191 maechler 549 
	errorcall(call, "at least 3 arguments required");
2 r 550 
 
648 ihaka 551 
    xlim = CAR(args);
5507 ihaka 552 
    if (!isNumeric(xlim) || LENGTH(xlim) != 2)
6191 maechler 553 
	errorcall(call, "invalid xlim");
648 ihaka 554 
    args = CDR(args);
2 r 555 
 
648 ihaka 556 
    ylim = CAR(args);
5507 ihaka 557 
    if (!isNumeric(ylim) || LENGTH(ylim) != 2)
6191 maechler 558 
	errorcall(call, "invalid ylim");
648 ihaka 559 
    args = CDR(args);
2 r 560 
 
10886 maechler 561 
    logscale = FALSE;
13046 maechler 562 
    logarg = CAR(args);
563 
    if (!isString(logarg))
5731 ripley 564 
	errorcall(call, "\"log=\" specification must be character");
13046 maechler 565 
    p = CHAR(STRING_ELT(logarg, 0));
648 ihaka 566 
    while (*p) {
567 
	switch (*p) {
568 
	case 'x':
17179 murrell 569 
	    Rf_dpptr(dd)->xlog = Rf_gpptr(dd)->xlog = logscale = TRUE;
648 ihaka 570 
	    break;
571 
	case 'y':
17179 murrell 572 
	    Rf_dpptr(dd)->ylog = Rf_gpptr(dd)->ylog = logscale = TRUE;
648 ihaka 573 
	    break;
574 
	default:
6222 pd 575 
	    errorcall(call,"invalid \"log=%s\" specification",p);
2 r 576 
	}
648 ihaka 577 
	p++;
578 
    }
579 
    args = CDR(args);
2 r 580 
 
11295 maechler 581 
    asp = (logscale) ? NA_REAL : asReal(CAR(args));;
658 ihaka 582 
    args = CDR(args);
583 
 
648 ihaka 584 
    GSavePars(dd);
19912 duncan 585 
    ProcessInlinePars(args, dd, call);
2 r 586 
 
5507 ihaka 587 
    if (isInteger(xlim)) {
588 
	if (INTEGER(xlim)[0] == NA_INTEGER || INTEGER(xlim)[1] == NA_INTEGER)
6191 maechler 589 
	    errorcall(call, "NAs not allowed in xlim");
648 ihaka 590 
	xmin = INTEGER(xlim)[0];
591 
	xmax = INTEGER(xlim)[1];
592 
    }
593 
    else {
5507 ihaka 594 
	if (!R_FINITE(REAL(xlim)[0]) || !R_FINITE(REAL(xlim)[1]))
6191 maechler 595 
	    errorcall(call, "need finite xlim values");
6099 pd 596 
	xmin = REAL(xlim)[0];
648 ihaka 597 
	xmax = REAL(xlim)[1];
598 
    }
5507 ihaka 599 
    if (isInteger(ylim)) {
600 
	if (INTEGER(ylim)[0] == NA_INTEGER || INTEGER(ylim)[1] == NA_INTEGER)
6191 maechler 601 
	    errorcall(call, "NAs not allowed in ylim");
648 ihaka 602 
	ymin = INTEGER(ylim)[0];
603 
	ymax = INTEGER(ylim)[1];
604 
    }
605 
    else {
5507 ihaka 606 
	if (!R_FINITE(REAL(ylim)[0]) || !R_FINITE(REAL(ylim)[1]))
6191 maechler 607 
	    errorcall(call, "need finite ylim values");
648 ihaka 608 
	ymin = REAL(ylim)[0];
609 
	ymax = REAL(ylim)[1];
610 
    }
17179 murrell 611 
    if ((Rf_dpptr(dd)->xlog && (xmin < 0 || xmax < 0)) ||
612 
       (Rf_dpptr(dd)->ylog && (ymin < 0 || ymax < 0)))
5731 ripley 613 
	    errorcall(call, "Logarithmic axis must have positive limits");
2711 maechler 614 
 
5107 maechler 615 
    if (R_FINITE(asp) && asp > 0) {
658 ihaka 616 
	double pin1, pin2, scale, xdelta, ydelta, xscale, yscale, xadd, yadd;
617 
	pin1 = GConvertXUnits(1.0, NPC, INCHES, dd);
618 
	pin2 = GConvertYUnits(1.0, NPC, INCHES, dd);
3049 r 619 
	xdelta = fabs(xmax - xmin) / asp;
783 maechler 620 
	ydelta = fabs(ymax - ymin);
27600 ripley 621 
	if(xdelta == 0.0 && ydelta == 0.0) {
622 
	    /* We really do mean zero: small non-zero values work
623 
	       Mimic the behaviour of GScale for the x axis. */
624 
	    xadd = yadd = ((xmin == 0.0) ? 1 : 0.4) * asp;
625 
	    xadd *= asp;
626 
	} else {
627 
	    xscale = pin1 / xdelta;
628 
	    yscale = pin2 / ydelta;
629 
	    scale = (xscale < yscale) ? xscale : yscale;
630 
	    xadd = .5 * (pin1 / scale - xdelta) * asp;
631 
	    yadd = .5 * (pin2 / scale - ydelta);
632 
	}
658 ihaka 633 
	GScale(xmin - xadd, xmax + xadd, 1, dd);
634 
	GScale(ymin - yadd, ymax + yadd, 2, dd);
635 
    }
636 
    else {
637 
	GScale(xmin, xmax, 1, dd);
638 
	GScale(ymin, ymax, 2, dd);
639 
    }
648 ihaka 640 
    GMapWin2Fig(dd);
641 
    GRestorePars(dd);
658 ihaka 642 
    /* NOTE: the operation is only recorded if there was no "error" */
11067 maechler 643 
    if (GRecording(call))
648 ihaka 644 
	recordGraphicOperation(op, originalArgs, dd);
645 
    return R_NilValue;
2 r 646 
}
647 
 
7812 murrell 648 
void GetAxisLimits(double left, double right, double *low, double *high)
2 r 649 
{
2666 maechler 650 
/*	Called from do_axis()	such as
17179 murrell 651 
 *	GetAxisLimits(Rf_gpptr(dd)->usr[0], Rf_gpptr(dd)->usr[1], &low, &high)
2666 maechler 652 
 *
3279 pd 653 
 *	Computes  *low < left, right < *high  (even if left=right)
2666 maechler 654 
 */
648 ihaka 655 
    double eps;
5507 ihaka 656 
    if (left > right) {/* swap */
2666 maechler 657 
	eps = left; left = right; right = eps;
648 ihaka 658 
    }
2666 maechler 659 
    eps = right - left;
5507 ihaka 660 
    if (eps == 0.)
2666 maechler 661 
	eps = 0.5 * FLT_EPSILON;
662 
    else
663 
	eps *= FLT_EPSILON;
664 
    *low = left - eps;
665 
    *high = right + eps;
2 r 666 
}
667 
 
668 
 
1839 ihaka 669 
/* axis(side, at, labels, ...) */
658 ihaka 670 
 
7812 murrell 671 
SEXP labelformat(SEXP labels)
658 ihaka 672 
{
12256 pd 673 
    /* format(labels): i.e. from numbers to strings */
1160 maechler 674 
    SEXP ans = R_NilValue;/* -Wall*/
12976 pd 675 
    int i, n, w, d, e, wi, di, ei;
658 ihaka 676 
    char *strp;
677 
    n = length(labels);
12256 pd 678 
    R_print.digits = 7;/* maximally 7 digits -- ``burnt in'';
16482 maechler 679 
			  S-PLUS <= 5.x has about 6
12256 pd 680 
			  (but really uses single precision..) */
658 ihaka 681 
    switch(TYPEOF(labels)) {
682 
    case LGLSXP:
683 
	PROTECT(ans = allocVector(STRSXP, n));
684 
	for (i = 0; i < n; i++) {
685 
	    strp = EncodeLogical(LOGICAL(labels)[i], 0);
10172 luke 686 
	    SET_STRING_ELT(ans, i, mkChar(strp));
658 ihaka 687 
	}
688 
	UNPROTECT(1);
689 
	break;
690 
    case INTSXP:
691 
	PROTECT(ans = allocVector(STRSXP, n));
692 
	for (i = 0; i < n; i++) {
693 
	    strp = EncodeInteger(INTEGER(labels)[i], 0);
10172 luke 694 
	    SET_STRING_ELT(ans, i, mkChar(strp));
658 ihaka 695 
	}
696 
	UNPROTECT(1);
697 
	break;
698 
    case REALSXP:
14357 ripley 699 
	formatReal(REAL(labels), n, &w, &d, &e, 0);
658 ihaka 700 
	PROTECT(ans = allocVector(STRSXP, n));
701 
	for (i = 0; i < n; i++) {
702 
	    strp = EncodeReal(REAL(labels)[i], 0, d, e);
10172 luke 703 
	    SET_STRING_ELT(ans, i, mkChar(strp));
658 ihaka 704 
	}
705 
	UNPROTECT(1);
706 
	break;
707 
    case CPLXSXP:
14357 ripley 708 
	formatComplex(COMPLEX(labels), n, &w, &d, &e, &wi, &di, &ei, 0);
658 ihaka 709 
	PROTECT(ans = allocVector(STRSXP, n));
710 
	for (i = 0; i < n; i++) {
711 
	    strp = EncodeComplex(COMPLEX(labels)[i], 0, d, e, 0, di, ei);
10172 luke 712 
	    SET_STRING_ELT(ans, i, mkChar(strp));
658 ihaka 713 
	}
714 
	UNPROTECT(1);
715 
	break;
716 
    case STRSXP:
717 
	PROTECT(ans = allocVector(STRSXP, n));
718 
	for (i = 0; i < n; i++) {
10172 luke 719 
	    SET_STRING_ELT(ans, i, STRING_ELT(labels, i));
658 ihaka 720 
	}
721 
	UNPROTECT(1);
722 
	break;
723 
    default:
5731 ripley 724 
	error("invalid type for axis labels");
658 ihaka 725 
    }
726 
    return ans;
727 
}
728 
 
13046 maechler 729 
SEXP CreateAtVector(double *axp, double *usr, int nint, Rboolean logflag)
658 ihaka 730 
{
2666 maechler 731 
/*	Create an  'at = ...' vector for  axis(.) / do_axis,
732 
 *	i.e., the vector of tick mark locations,
733 
 *	when none has been specified (= default).
734 
 *
21044 maechler 735 
 *	axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks
736 
 *                 {unless in log case, where nint \in {1,2,3 ; -1,-2,....}
737 
 *                  and the `nint' argument is used.
738 
 
2666 maechler 739 
 *	The resulting REAL vector must have length >= 1, ideally >= 2
740 
 */
987 maechler 741 
    SEXP at = R_NilValue;/* -Wall*/
759 ihaka 742 
    double umin, umax, dn, rng, small;
2666 maechler 743 
    int i, n, ne;
21044 maechler 744 
    if (!logflag || axp[2] < 0) { /* --- linear axis --- Only use axp[] arg. */
2666 maechler 745 
	n = fabs(axp[2]) + 0.25;/* >= 0 */
8267 ripley 746 
	dn = imax2(1, n);
658 ihaka 747 
	rng = axp[1] - axp[0];
2666 maechler 748 
	small = fabs(rng)/(100.*dn);
658 ihaka 749 
	at = allocVector(REALSXP, n + 1);
5507 ihaka 750 
	for (i = 0; i <= n; i++) {
658 ihaka 751 
	    REAL(at)[i] = axp[0] + (i / dn) * rng;
759 ihaka 752 
	    if (fabs(REAL(at)[i]) < small)
783 maechler 753 
		REAL(at)[i] = 0;
8552 maechler 754 
	}
658 ihaka 755 
    }
2669 maechler 756 
    else { /* ------ log axis ----- */
658 ihaka 757 
	n = (axp[2] + 0.5);
2669 maechler 758 
	/* {xy}axp[2] for 'log': GLpretty() [../graphics.c] sets
2666 maechler 759 
	   n < 0: very small scale ==> linear axis, above, or
760 
	   n = 1,2,3.  see switch() below */
658 ihaka 761 
	umin = usr[0];
762 
	umax = usr[1];
2669 maechler 763 
	/* Debugging: When does the following happen... ? */
5507 ihaka 764 
	if (umin > umax)
2674 maechler 765 
	    warning("CreateAtVector \"log\"(from axis()): "
4179 rgentlem 766 
		    "usr[0] = %g > %g = usr[1] !", umin, umax);
2690 maechler 767 
	dn = axp[0];
5507 ihaka 768 
	if (dn < 1e-300)
4179 rgentlem 769 
	    warning("CreateAtVector \"log\"(from axis()): axp[0] = %g !", dn);
2669 maechler 770 
 
2666 maechler 771 
	/* You get the 3 cases below by
5507 ihaka 772 
	 *  for (y in 1e-5*c(1,2,8))  plot(y, log = "y")
2666 maechler 773 
	 */
658 ihaka 774 
	switch(n) {
2666 maechler 775 
	case 1: /* large range:	1	 * 10^k */
776 
	    i = floor(log10(axp[1])) - ceil(log10(axp[0])) + 0.25;
777 
	    ne = i / nint + 1;
5507 ihaka 778 
	    if (ne < 1)
2690 maechler 779 
		error("log - axis(), 'at' creation, _LARGE_ range: "
780 
		      "ne = %d <= 0 !!\n"
5731 ripley 781 
		      "\t axp[0:1]=(%g,%g) ==> i = %d;	nint = %d",
2690 maechler 782 
		      ne, axp[0],axp[1], i, nint);
783 
	    rng = pow(10., (double)ne);/* >= 10 */
658 ihaka 784 
	    n = 0;
5507 ihaka 785 
	    while (dn < umax) {
658 ihaka 786 
		n++;
2016 pd 787 
		dn *= rng;
658 ihaka 788 
	    }
5507 ihaka 789 
	    if (!n)
2666 maechler 790 
		error("log - axis(), 'at' creation, _LARGE_ range: "
791 
		      "illegal {xy}axp or par; nint=%d\n"
5731 ripley 792 
		      "	 axp[0:1]=(%g,%g), usr[0:1]=(%g,%g); i=%d, ni=%d",
2666 maechler 793 
		      nint, axp[0],axp[1], umin,umax, i,ne);
658 ihaka 794 
	    at = allocVector(REALSXP, n);
795 
	    dn = axp[0];
796 
	    n = 0;
5507 ihaka 797 
	    while (dn < umax) {
658 ihaka 798 
		REAL(at)[n++] = dn;
2016 pd 799 
		dn *= rng;
658 ihaka 800 
	    }
801 
	    break;
2666 maechler 802 
 
803 
	case 2: /* medium range:  1, 5	  * 10^k */
658 ihaka 804 
	    n = 0;
5507 ihaka 805 
	    if (0.5 * dn >= umin) n++;
806 
	    for (;;) {
807 
		if (dn > umax) break;		n++;
808 
		if (5 * dn > umax) break;	n++;
2666 maechler 809 
		dn *= 10;
658 ihaka 810 
	    }
5507 ihaka 811 
	    if (!n)
2666 maechler 812 
		error("log - axis(), 'at' creation, _MEDIUM_ range: "
813 
		      "illegal {xy}axp or par;\n"
5731 ripley 814 
		      "	 axp[0]= %g, usr[0:1]=(%g,%g)",
2666 maechler 815 
		      axp[0], umin,umax);
816 
 
658 ihaka 817 
	    at = allocVector(REALSXP, n);
818 
	    dn = axp[0];
819 
	    n = 0;
5507 ihaka 820 
	    if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
821 
	    for (;;) {
822 
		if (dn > umax) break;		REAL(at)[n++] = dn;
823 
		if (5 * dn > umax) break;	REAL(at)[n++] = 5 * dn;
2666 maechler 824 
		dn *= 10;
658 ihaka 825 
	    }
826 
	    break;
2666 maechler 827 
 
828 
	case 3: /* small range:	 1,2,5,10 * 10^k */
658 ihaka 829 
	    n = 0;
5507 ihaka 830 
	    if (0.2 * dn >= umin) n++;
831 
	    if (0.5 * dn >= umin) n++;
832 
	    for (;;) {
833 
		if (dn > umax) break;		n++;
834 
		if (2 * dn > umax) break;	n++;
835 
		if (5 * dn > umax) break;	n++;
2666 maechler 836 
		dn *= 10;
658 ihaka 837 
	    }
5507 ihaka 838 
	    if (!n)
2666 maechler 839 
		error("log - axis(), 'at' creation, _SMALL_ range: "
840 
		      "illegal {xy}axp or par;\n"
5731 ripley 841 
		      "	 axp[0]= %g, usr[0:1]=(%g,%g)",
2666 maechler 842 
		      axp[0], umin,umax);
658 ihaka 843 
	    at = allocVector(REALSXP, n);
844 
	    dn = axp[0];
845 
	    n = 0;
5507 ihaka 846 
	    if (0.2 * dn >= umin) REAL(at)[n++] = 0.2 * dn;
847 
	    if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
848 
	    for (;;) {
849 
		if (dn > umax) break;		REAL(at)[n++] = dn;
850 
		if (2 * dn > umax) break;	REAL(at)[n++] = 2 * dn;
851 
		if (5 * dn > umax) break;	REAL(at)[n++] = 5 * dn;
2666 maechler 852 
		dn *= 10;
658 ihaka 853 
	    }
854 
	    break;
2666 maechler 855 
	default:
5731 ripley 856 
	    error("log - axis(), 'at' creation: ILLEGAL {xy}axp[3] = %g",
2666 maechler 857 
		  axp[2]);
658 ihaka 858 
	}
859 
    }
860 
    return at;
861 
}
862 
 
2 r 863 
SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env)
864 
{
19936 maechler 865 
    /* axis(side, at, labels, tick, line, pos,
21044 maechler 866 
     *	    outer, font, vfont, lty, lwd, col, ...) */
10886 maechler 867 
 
868 
    SEXP at, lab, vfont;
19936 maechler 869 
    int col, font, lty;
27757 ripley 870 
    int i, n, nint = 0, ntmp, side, *ind, outer, lineoff = 0;
10638 ihaka 871 
    int istart, iend, incr;
10886 maechler 872 
    Rboolean dolabels, doticks, logflag = FALSE;
21044 maechler 873 
    Rboolean create_at, vectorFonts = FALSE;
9434 ihaka 874 
    double x, y, temp, tnew, tlast;
658 ihaka 875 
    double axp[3], usr[2];
19936 maechler 876 
    double gap, labw, low, high, line, pos, lwd;
9434 ihaka 877 
    double axis_base, axis_tick, axis_lab, axis_low, axis_high;
658 ihaka 878 
 
18961 ripley 879 
    SEXP originalArgs = args, label;
658 ihaka 880 
    DevDesc *dd = CurrentDevice();
881 
 
9434 ihaka 882 
    /* Arity Check */
883 
    /* This is a builtin function, so it should always have */
884 
    /* the correct arity, but it doesn't hurt to be defensive. */
658 ihaka 885 
 
10886 maechler 886 
    if (length(args) < 9)
887 
	errorcall(call, "too few arguments");
658 ihaka 888 
    GCheckState(dd);
889 
 
9434 ihaka 890 
    /* Required argument: "side" */
891 
    /* Which side of the plot the axis is to appear on. */
892 
    /* side = 1 | 2 | 3 | 4. */
658 ihaka 893 
 
1365 maechler 894 
    side = asInteger(CAR(args));
895 
    if (side < 1 || side > 4)
13046 maechler 896 
	errorcall(call, "invalid axis number %d", side);
2666 maechler 897 
    args = CDR(args);
658 ihaka 898 
 
9434 ihaka 899 
    /* Required argument: "at" */
900 
    /* This gives the tick-label locations. */
901 
    /* Note that these are coerced to the correct type below. */
658 ihaka 902 
 
1365 maechler 903 
    at = CAR(args); args = CDR(args);
658 ihaka 904 
 
9434 ihaka 905 
    /* Required argument: "labels" */
906 
    /* Labels can be a logical, indicating whether or not */
907 
    /* to label the axis; or it can be a vector of character */
908 
    /* strings or expressions which give the labels explicitly. */
909 
    /* The expressions are used to set mathematical labelling. */
658 ihaka 910 
 
10886 maechler 911 
    dolabels = TRUE;
658 ihaka 912 
    if (isLogical(CAR(args)) && length(CAR(args)) > 0) {
913 
	i = asLogical(CAR(args));
5507 ihaka 914 
	if (i == 0 || i == NA_LOGICAL)
10886 maechler 915 
	    dolabels = FALSE;
664 ihaka 916 
	PROTECT(lab = R_NilValue);
9434 ihaka 917 
    }
918 
    else if (isExpression(CAR(args))) {
658 ihaka 919 
	PROTECT(lab = CAR(args));
9434 ihaka 920 
    }
921 
    else {
668 ihaka 922 
	PROTECT(lab = coerceVector(CAR(args), STRSXP));
658 ihaka 923 
    }
924 
    args = CDR(args);
925 
 
19936 maechler 926 
    /* Required argument: "tick" */
9434 ihaka 927 
    /* This indicates whether or not ticks and the axis line */
928 
    /* should be plotted: TRUE => show, FALSE => don't show. */
929 
 
930 
    doticks = asLogical(CAR(args));
10886 maechler 931 
    doticks = (doticks == NA_LOGICAL) ? TRUE : (Rboolean) doticks;
9434 ihaka 932 
    args = CDR(args);
933 
 
934 
    /* Optional argument: "line" */
935 
 
19936 maechler 936 
    /* Specifies an offset outward from the plot for the axis.
937 
     * The values in the par value "mgp" are interpreted
938 
     * relative to this value. */
9434 ihaka 939 
    line = asReal(CAR(args));
27757 ripley 940 
    if (!R_FINITE(line)) {
941 
	/* Except that here mgp values are not relative to themselves */
942 
	line = Rf_gpptr(dd)->mgp[2];
943 
	lineoff = line;
944 
    }
9434 ihaka 945 
    args = CDR(args);
946 
 
947 
    /* Optional argument: "pos" */
948 
    /* Specifies a user coordinate at which the axis should be drawn. */
949 
    /* This overrides the value of "line".  Again the "mgp" par values */
950 
    /* are interpreted relative to this value. */
951 
 
952 
    pos = asReal(CAR(args));
27757 ripley 953 
    if (!R_FINITE(pos)) pos = NA_REAL; else lineoff = 0;
9434 ihaka 954 
    args = CDR(args);
955 
 
956 
    /* Optional argument: "outer" */
957 
    /* Should the axis be drawn in the outer margin. */
958 
    /* This only affects the computation of axis_base. */
959 
 
960 
    outer = asLogical(CAR(args));
961 
    if (outer == NA_LOGICAL || outer == 0)
962 
	outer = NPC;
963 
    else
964 
	outer = NIC;
10886 maechler 965 
    args = CDR(args);
9687 pd 966 
 
10886 maechler 967 
    /* Optional argument: "font" */
968 
    font = asInteger(FixupFont(CAR(args), NA_INTEGER));
9434 ihaka 969 
    args = CDR(args);
970 
 
10886 maechler 971 
    /* Optional argument: "vfont" */
972 
    /* Allows Hershey vector fonts to be used */
973 
    PROTECT(vfont = FixupVFont(CAR(args)));
974 
    if (!isNull(vfont))
975 
	vectorFonts = TRUE;
976 
    args = CDR(args);
977 
 
19936 maechler 978 
    /* Optional argument: "lty" */
979 
    lty = asInteger(FixupLty(CAR(args), NA_INTEGER));
980 
    args = CDR(args);
10886 maechler 981 
 
19936 maechler 982 
    /* Optional argument: "lwd" */
983 
    lwd = asReal(FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
984 
    args = CDR(args);
985 
 
986 
    /* Optional argument: "col" */
987 
    col = asInteger(FixupCol(CAR(args), Rf_gpptr(dd)->fg));
988 
    args = CDR(args);
989 
 
3682 r 990 
    /* Retrieve relevant "par" values. */
658 ihaka 991 
 
1365 maechler 992 
    switch(side) {
5107 maechler 993 
    case 1:
658 ihaka 994 
    case 3:
17179 murrell 995 
	axp[0] = Rf_dpptr(dd)->xaxp[0];
996 
	axp[1] = Rf_dpptr(dd)->xaxp[1];
997 
	axp[2] = Rf_dpptr(dd)->xaxp[2];
998 
	usr[0] = Rf_dpptr(dd)->usr[0];
999 
	usr[1] = Rf_dpptr(dd)->usr[1];
1000 
	logflag = Rf_dpptr(dd)->xlog;
1001 
	nint = Rf_dpptr(dd)->lab[0];
658 ihaka 1002 
	break;
1003 
    case 2:
1004 
    case 4:
17179 murrell 1005 
	axp[0] = Rf_dpptr(dd)->yaxp[0];
1006 
	axp[1] = Rf_dpptr(dd)->yaxp[1];
1007 
	axp[2] = Rf_dpptr(dd)->yaxp[2];
1008 
	usr[0] = Rf_dpptr(dd)->usr[2];
1009 
	usr[1] = Rf_dpptr(dd)->usr[3];
1010 
	logflag = Rf_dpptr(dd)->ylog;
1011 
	nint = Rf_dpptr(dd)->lab[1];
658 ihaka 1012 
	break;
1013 
    }
783 maechler 1014 
 
9434 ihaka 1015 
    /* Determine the tickmark positions.  Note that these may fall */
3682 r 1016 
    /* outside the plot window. We will clip them in the code below. */
2666 maechler 1017 
 
21044 maechler 1018 
    create_at = (length(at) == 0);
1019 
    if (create_at) {
658 ihaka 1020 
	PROTECT(at = CreateAtVector(axp, usr, nint, logflag));
1021 
    }
1022 
    else {
1023 
	if (isReal(at)) PROTECT(at = duplicate(at));
1024 
	else PROTECT(at = coerceVector(at, REALSXP));
1025 
    }
7153 maechler 1026 
    n = length(at);
658 ihaka 1027 
 
9434 ihaka 1028 
    /* Check/setup the tick labels.  This can mean using user-specified */
1029 
    /* labels, or encoding the "at" positions as strings. */
1030 
 
658 ihaka 1031 
    if (dolabels) {
5507 ihaka 1032 
	if (length(lab) == 0)
658 ihaka 1033 
	    lab = labelformat(at);
668 ihaka 1034 
	else if (!isExpression(lab))
658 ihaka 1035 
	    lab = labelformat(lab);
783 maechler 1036 
	if (length(at) != length(lab))
13046 maechler 1037 
	    errorcall(call, "location and label lengths differ, %d != %d",
1038 
		      length(at), length(lab));
658 ihaka 1039 
    }
8258 pd 1040 
    PROTECT(lab);
9434 ihaka 1041 
 
1042 
    /* Check there are no NA, Inf or -Inf values for tick positions. */
1043 
    /* The code here is long-winded.  Couldn't we just inline things */
1044 
    /* below.  Hmmm - we need the min and max of the finite values ... */
1045 
 
5510 ripley 1046 
    ind = (int *) R_alloc(n, sizeof(int));
1047 
    for(i = 0; i < n; i++) ind[i] = i;
1048 
    rsort_with_index(REAL(at), ind, n);
8266 ripley 1049 
    ntmp = 0;
1050 
    for(i = 0; i < n; i++) {
8267 ripley 1051 
	if(R_FINITE(REAL(at)[i])) ntmp = i+1;
8266 ripley 1052 
    }
1053 
    n = ntmp;
1054 
    if (n == 0)
1055 
	errorcall(call, "no locations are finite");
1056 
 
19936 maechler 1057 
    /* Ok, all systems are "GO".  Let's get to it.
1058 
     * First we process all the remaining inline par values */
658 ihaka 1059 
    GSavePars(dd);
19912 duncan 1060 
    ProcessInlinePars(args, dd, call);
9434 ihaka 1061 
 
12256 pd 1062 
    /* At this point we know the value of "xaxt" and "yaxt",
1063 
     * so we test to see whether the relevant one is "n".
1064 
     * If it is, we just bail out at this point. */
9687 pd 1065 
 
17179 murrell 1066 
    if (((side == 1 || side == 3) && Rf_gpptr(dd)->xaxt == 'n') ||
1067 
	((side == 2 || side == 4) && Rf_gpptr(dd)->yaxt == 'n')) {
9434 ihaka 1068 
	GRestorePars(dd);
10886 maechler 1069 
	UNPROTECT(4);
9434 ihaka 1070 
	return R_NilValue;
1071 
    }
1072 
 
1073 
 
19936 maechler 1074 
    /* no! we do allow an `lty' argument -- will not be used often though
21044 maechler 1075 
     *	Rf_gpptr(dd)->lty = LTY_SOLID; */
19936 maechler 1076 
    Rf_gpptr(dd)->lty = lty;
1077 
    Rf_gpptr(dd)->lwd = lwd;
658 ihaka 1078 
 
12256 pd 1079 
    /* Override par("xpd") and force clipping to figure region.
1080 
     * NOTE: don't override to _reduce_ clipping region */
9434 ihaka 1081 
 
17179 murrell 1082 
    Rf_gpptr(dd)->xpd = 2;
5055 pd 1083 
 
17179 murrell 1084 
    Rf_gpptr(dd)->adj = 0.5;
1085 
    Rf_gpptr(dd)->font = (font == NA_INTEGER)? Rf_gpptr(dd)->fontaxis : font;
1086 
    Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * Rf_gpptr(dd)->cexaxis;
19936 maechler 1087 
    /* no!   col = Rf_gpptr(dd)->col; */
658 ihaka 1088 
 
1089 
    /* Draw the axis */
3367 ihaka 1090 
    GMode(1, dd);
1365 maechler 1091 
    switch (side) {
3475 pd 1092 
    case 1: /*--- x-axis -- horizontal --- */
658 ihaka 1093 
    case 3:
17179 murrell 1094 
	GetAxisLimits(Rf_gpptr(dd)->usr[0], Rf_gpptr(dd)->usr[1], &low, &high);
9434 ihaka 1095 
	axis_low  = GConvertX(fmax2(low, REAL(at)[0]), USER, NFC, dd);
1096 
	axis_high = GConvertX(fmin2(high, REAL(at)[n-1]), USER, NFC, dd);
1097 
	if (side == 1) {
1098 
	    if (R_FINITE(pos))
1099 
		axis_base = GConvertY(pos, USER, NFC, dd);
1100 
	    else
1101 
		axis_base = GConvertY(0.0, outer, NFC, dd)
1102 
		    - GConvertYUnits(line, LINES, NFC, dd);
26007 ripley 1103 
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1104 
		double len, xu, yu;
26479 maechler 1105 
		if(Rf_gpptr(dd)->tck > 0.5)
26007 ripley 1106 
		    len = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1107 
		else {
1108 
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1109 
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1110 
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1111 
		    len = GConvertYUnits(xu, INCHES, NFC, dd);
1112 
		}
1113 
		axis_tick = axis_base + len;
1114 
 
1115 
	    } else
19936 maechler 1116 
		axis_tick = axis_base +
1117 
			GConvertYUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
658 ihaka 1118 
	}
9434 ihaka 1119 
	else {
1120 
	    if (R_FINITE(pos))
1121 
		axis_base = GConvertY(pos, USER, NFC, dd);
1122 
	    else
1123 
		axis_base =  GConvertY(1.0, outer, NFC, dd)
1124 
		    + GConvertYUnits(line, LINES, NFC, dd);
26007 ripley 1125 
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1126 
		double len, xu, yu;
26479 maechler 1127 
		if(Rf_gpptr(dd)->tck > 0.5)
26007 ripley 1128 
		    len = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1129 
		else {
1130 
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1131 
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1132 
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1133 
		    len = GConvertYUnits(xu, INCHES, NFC, dd);
1134 
		}
1135 
		axis_tick = axis_base - len;
1136 
	    } else
26479 maechler 1137 
		axis_tick = axis_base -
26007 ripley 1138 
		    GConvertYUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
658 ihaka 1139 
	}
9434 ihaka 1140 
	if (doticks) {
19936 maechler 1141 
	    Rf_gpptr(dd)->col = col;/*was fg */
16482 maechler 1142 
	    GLine(axis_low, axis_base, axis_high, axis_base, NFC, dd);
746 ihaka 1143 
	    for (i = 0; i < n; i++) {
1144 
		x = REAL(at)[i];
1145 
		if (low <= x && x <= high) {
9434 ihaka 1146 
		    x = GConvertX(x, USER, NFC, dd);
1147 
		    GLine(x, axis_base, x, axis_tick, NFC, dd);
746 ihaka 1148 
		}
1149 
	    }
1150 
	}
9434 ihaka 1151 
	/* Tickmark labels. */
17179 murrell 1152 
	Rf_gpptr(dd)->col = Rf_gpptr(dd)->colaxis;
7153 maechler 1153 
	gap = GStrWidth("m", NFC, dd);	/* FIXUP x/y distance */
658 ihaka 1154 
	tlast = -1.0;
17179 murrell 1155 
	if (Rf_gpptr(dd)->las == 2 || Rf_gpptr(dd)->las == 3) {
1156 
	    Rf_gpptr(dd)->adj = (side == 1) ? 1 : 0;
4593 ihaka 1157 
	}
17179 murrell 1158 
	else Rf_gpptr(dd)->adj = 0.5;
9434 ihaka 1159 
	if (side == 1) {
1160 
	    axis_lab = - axis_base
27757 ripley 1161 
		+ GConvertYUnits(Rf_gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
9434 ihaka 1162 
		+ GConvertY(0.0, NPC, NFC, dd);
1163 
	}
19936 maechler 1164 
	else { /* side == 3 */
9434 ihaka 1165 
	    axis_lab = axis_base
27757 ripley 1166 
		+ GConvertYUnits(Rf_gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
21044 maechler 1167 
		- GConvertY(1.0, NPC, NFC, dd);
9434 ihaka 1168 
	}
1169 
	axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);
10638 ihaka 1170 
 
1171 
	/* The order of processing is important here. */
1172 
	/* We must ensure that the labels are drawn left-to-right. */
1173 
	/* The logic here is getting way too convoluted. */
1174 
	/* This needs a serious rewrite. */
1175 
 
17179 murrell 1176 
	if (Rf_gpptr(dd)->usr[0] > Rf_gpptr(dd)->usr[1]) {
10638 ihaka 1177 
	    istart = n - 1;
1178 
	    iend = -1;
1179 
	    incr = -1;
1180 
	}
1181 
	else {
1182 
	    istart = 0;
1183 
	    iend = n;
1184 
	    incr = 1;
1185 
	}
1186 
	for (i = istart; i != iend; i += incr) {
658 ihaka 1187 
	    x = REAL(at)[i];
8266 ripley 1188 
	    if (!R_FINITE(x)) continue;
9434 ihaka 1189 
	    temp = GConvertX(x, USER, NFC, dd);
664 ihaka 1190 
	    if (dolabels) {
9434 ihaka 1191 
		/* Clip tick labels to user coordinates. */
8291 murrell 1192 
		if (x > low && x < high) {
1193 
		    if (isExpression(lab)) {
10172 luke 1194 
			GMMathText(VECTOR_ELT(lab, ind[i]), side,
17179 murrell 1195 
				   axis_lab, 0, x, Rf_gpptr(dd)->las, dd);
664 ihaka 1196 
		    }
8291 murrell 1197 
		    else {
20375 ripley 1198 
			label = STRING_ELT(lab, ind[i]);
1199 
			if(label != NA_STRING) {
1200 
			    labw = GStrWidth(CHAR(label), NFC, dd);
1201 
			    tnew = temp - 0.5 * labw;
1202 
			    /* Check room for perpendicular labels. */
1203 
			    if (Rf_gpptr(dd)->las == 2 ||
1204 
				Rf_gpptr(dd)->las == 3 ||
1205 
				tnew - tlast >= gap) {
19936 maechler 1206 
				GMtext(CHAR(label), side, axis_lab, 0, x,
18961 ripley 1207 
				       Rf_gpptr(dd)->las, dd);
1208 
				tlast = temp + 0.5 *labw;
1209 
			    }
8291 murrell 1210 
			}
1211 
		    }
783 maechler 1212 
		}
658 ihaka 1213 
	    }
1214 
	}
1215 
	break;
3475 pd 1216 
 
1217 
    case 2: /*--- y-axis -- vertical --- */
658 ihaka 1218 
    case 4:
17179 murrell 1219 
	GetAxisLimits(Rf_gpptr(dd)->usr[2], Rf_gpptr(dd)->usr[3], &low, &high);
9434 ihaka 1220 
	axis_low = GConvertY(fmax2(low, REAL(at)[0]), USER, NFC, dd);
1221 
	axis_high = GConvertY(fmin2(high, REAL(at)[n-1]), USER, NFC, dd);
1222 
	if (side == 2) {
1223 
	    if (R_FINITE(pos))
1224 
		axis_base = GConvertX(pos, USER, NFC, dd);
1225 
	    else
1226 
		axis_base =  GConvertX(0.0, outer, NFC, dd)
1227 
		    - GConvertXUnits(line, LINES, NFC, dd);
26007 ripley 1228 
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1229 
		double len, xu, yu;
26479 maechler 1230 
		if(Rf_gpptr(dd)->tck > 0.5)
26007 ripley 1231 
		    len = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1232 
		else {
1233 
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1234 
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1235 
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1236 
		    len = GConvertXUnits(xu, INCHES, NFC, dd);
1237 
		}
1238 
		axis_tick = axis_base + len;
1239 
	    } else
26479 maechler 1240 
		axis_tick = axis_base +
26007 ripley 1241 
		    GConvertXUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
658 ihaka 1242 
	}
9434 ihaka 1243 
	else {
1244 
	    if (R_FINITE(pos))
1245 
		axis_base = GConvertX(pos, USER, NFC, dd);
1246 
	    else
1247 
		axis_base =  GConvertX(1.0, outer, NFC, dd)
1248 
		    + GConvertXUnits(line, LINES, NFC, dd);
26007 ripley 1249 
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1250 
		double len, xu, yu;
26479 maechler 1251 
		if(Rf_gpptr(dd)->tck > 0.5)
26007 ripley 1252 
		    len = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1253 
		else {
1254 
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1255 
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1256 
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1257 
		    len = GConvertXUnits(xu, INCHES, NFC, dd);
1258 
		}
1259 
		axis_tick = axis_base - len;
1260 
	    } else
26479 maechler 1261 
		axis_tick = axis_base -
26007 ripley 1262 
		    GConvertXUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
658 ihaka 1263 
	}
9434 ihaka 1264 
	if (doticks) {
19936 maechler 1265 
	    Rf_gpptr(dd)->col = col;/*was fg */
16482 maechler 1266 
	    GLine(axis_base, axis_low, axis_base, axis_high, NFC, dd);
746 ihaka 1267 
	    for (i = 0; i < n; i++) {
1268 
		y = REAL(at)[i];
1269 
		if (low <= y && y <= high) {
9434 ihaka 1270 
		    y = GConvertY(y, USER, NFC, dd);
1271 
		    GLine(axis_base, y, axis_tick, y, NFC, dd);
746 ihaka 1272 
		}
1273 
	    }
1274 
	}
9434 ihaka 1275 
	/* Tickmark labels. */
17179 murrell 1276 
	Rf_gpptr(dd)->col = Rf_gpptr(dd)->colaxis;
658 ihaka 1277 
	gap = GStrWidth("m", INCHES, dd);
1278 
	gap = GConvertYUnits(gap, INCHES, NFC, dd);
1279 
	tlast = -1.0;
17179 murrell 1280 
	if (Rf_gpptr(dd)->las == 1 || Rf_gpptr(dd)->las == 2) {
1281 
	    Rf_gpptr(dd)->adj = (side == 2) ? 1 : 0;
4593 ihaka 1282 
	}
17179 murrell 1283 
	else Rf_gpptr(dd)->adj = 0.5;
9434 ihaka 1284 
	if (side == 2) {
1285 
	    axis_lab = - axis_base
27757 ripley 1286 
		+ GConvertXUnits(Rf_gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
9434 ihaka 1287 
		+ GConvertX(0.0, NPC, NFC, dd);
1288 
	}
19936 maechler 1289 
	else { /* side == 4 */
9434 ihaka 1290 
	    axis_lab = axis_base
27757 ripley 1291 
		+ GConvertXUnits(Rf_gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
9434 ihaka 1292 
		- GConvertX(1.0, NPC, NFC, dd);
1293 
	}
1294 
	axis_lab = GConvertXUnits(axis_lab, NFC, LINES, dd);
10638 ihaka 1295 
 
1296 
	/* The order of processing is important here. */
1297 
	/* We must ensure that the labels are drawn left-to-right. */
1298 
	/* The logic here is getting way too convoluted. */
1299 
	/* This needs a serious rewrite. */
1300 
 
17179 murrell 1301 
	if (Rf_gpptr(dd)->usr[2] > Rf_gpptr(dd)->usr[3]) {
10638 ihaka 1302 
	    istart = n - 1;
1303 
	    iend = -1;
1304 
	    incr = -1;
1305 
	}
1306 
	else {
1307 
	    istart = 0;
1308 
	    iend = n;
1309 
	    incr = 1;
1310 
	}
1311 
	for (i = istart; i != iend; i += incr) {
658 ihaka 1312 
	    y = REAL(at)[i];
8266 ripley 1313 
	    if (!R_FINITE(y)) continue;
9434 ihaka 1314 
	    temp = GConvertY(y, USER, NFC, dd);
664 ihaka 1315 
	    if (dolabels) {
9434 ihaka 1316 
		/* Clip tick labels to user coordinates. */
8291 murrell 1317 
		if (y > low && y < high) {
1318 
		    if (isExpression(lab)) {
10172 luke 1319 
			GMMathText(VECTOR_ELT(lab, ind[i]), side,
17179 murrell 1320 
				   axis_lab, 0, y, Rf_gpptr(dd)->las, dd);
664 ihaka 1321 
		    }
8291 murrell 1322 
		    else {
20375 ripley 1323 
			label = STRING_ELT(lab, ind[i]);
1324 
			if(label != NA_STRING) {
1325 
			    labw = GStrWidth(CHAR(label), INCHES, dd);
1326 
			    labw = GConvertYUnits(labw, INCHES, NFC, dd);
1327 
			    tnew = temp - 0.5 * labw;
1328 
			    /* Check room for perpendicular labels. */
1329 
			    if (Rf_gpptr(dd)->las == 1 ||
1330 
				Rf_gpptr(dd)->las == 2 ||
1331 
				tnew - tlast >= gap) {
19936 maechler 1332 
				GMtext(CHAR(label), side, axis_lab, 0, y,
18961 ripley 1333 
				       Rf_gpptr(dd)->las, dd);
1334 
				tlast = temp + 0.5 *labw;
1335 
			    }
8291 murrell 1336 
			}
1337 
		    }
783 maechler 1338 
		}
658 ihaka 1339 
	    }
1340 
	}
1341 
	break;
7153 maechler 1342 
    } /* end  switch(side, ..) */
10886 maechler 1343 
    UNPROTECT(4); /* lab, vfont, at, lab again */
3367 ihaka 1344 
    GMode(0, dd);
658 ihaka 1345 
    GRestorePars(dd);
1346 
    /* NOTE: only record operation if no "error"  */
11067 maechler 1347 
    if (GRecording(call))
658 ihaka 1348 
	recordGraphicOperation(op, originalArgs, dd);
1349 
    return R_NilValue;
10886 maechler 1350 
}/* do_axis */
658 ihaka 1351 
 
2 r 1352 
 
1353 
SEXP do_plot_xy(SEXP call, SEXP op, SEXP args, SEXP env)
1354 
{
2674 maechler 1355 
/*	plot.xy(xy, type, pch, lty, col, cex, ...)
1356 
 
1357 
 *	plot points or lines of various types
1358 
 */
648 ihaka 1359 
    SEXP sxy, sx, sy, pch, cex, col, bg, lty;
6994 pd 1360 
    double *x, *y, xold, yold, xx, yy, thiscex;
1361 
    int i, n, npch, ncex, ncol, nbg, nlty, type=0, start=0, thispch, thiscol;
7081 pd 1362 
 
648 ihaka 1363 
    SEXP originalArgs = args;
1364 
    DevDesc *dd = CurrentDevice();
2 r 1365 
 
648 ihaka 1366 
    /* Basic Checks */
1367 
    GCheckState(dd);
5507 ihaka 1368 
    if (length(args) < 6)
6191 maechler 1369 
	errorcall(call, "too few arguments");
2 r 1370 
 
648 ihaka 1371 
    /* Required Arguments */
10217 pd 1372 
#define PLOT_XY_DEALING(subname)				\
16482 maechler 1373 
    sx = R_NilValue;		/* -Wall */			\
1374 
    sy = R_NilValue;		/* -Wall */			\
10217 pd 1375 
    sxy = CAR(args);						\
1376 
    if (isNewList(sxy) && length(sxy) >= 2) {			\
1377 
	internalTypeCheck(call, sx = VECTOR_ELT(sxy, 0), REALSXP);	\
1378 
	internalTypeCheck(call, sy = VECTOR_ELT(sxy, 1), REALSXP);	\
1379 
    }								\
1380 
    else if (isList(sxy) && length(sxy) >= 2) {			\
1381 
	internalTypeCheck(call, sx = CAR(sxy), REALSXP);	\
1382 
	internalTypeCheck(call, sy = CADR(sxy), REALSXP);	\
1383 
    }								\
1384 
    else							\
1385 
	errorcall(call, "invalid plotting structure");		\
1386 
    if (LENGTH(sx) != LENGTH(sy))				\
20243 ripley 1387 
	error("x and y lengths differ in " subname "().");	\
10217 pd 1388 
    n = LENGTH(sx);						\
1389 
    args = CDR(args)
2 r 1390 
 
10217 pd 1391 
    PLOT_XY_DEALING("plot.xy");
1392 
 
5507 ihaka 1393 
    if (isNull(CAR(args))) type = 'p';
648 ihaka 1394 
    else {
9940 pd 1395 
	if (isString(CAR(args)) && LENGTH(CAR(args)) == 1 &&
10172 luke 1396 
	    LENGTH(pch = STRING_ELT(CAR(args), 0)) >= 1) {
9940 pd 1397 
	    if(LENGTH(pch) > 1)
1398 
		warningcall(call, "plot type '%s' truncated to first character",
1399 
			    CHAR(pch));
1400 
	    type = CHAR(pch)[0];
1401 
	}
5731 ripley 1402 
	else errorcall(call, "invalid plot type");
648 ihaka 1403 
    }
1404 
    args = CDR(args);
2 r 1405 
 
17179 murrell 1406 
    PROTECT(pch = FixupPch(CAR(args), Rf_gpptr(dd)->pch));	args = CDR(args);
2711 maechler 1407 
    npch = length(pch);
2 r 1408 
 
17179 murrell 1409 
    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));	args = CDR(args);
2711 maechler 1410 
    nlty = length(lty);
2 r 1411 
 
6994 pd 1412 
    /* Default col was NA_INTEGER (0x80000000) which was interpreted
1413 
       as zero (black) or "don't draw" depending on line/rect/circle
1414 
       situation. Now we set the default to zero and don't plot at all
1415 
       if col==NA.
7081 pd 1416 
 
6994 pd 1417 
       FIXME: bg needs similar change, but that requires changes to
1418 
       the specific drivers. */
1419 
 
7081 pd 1420 
    PROTECT(col = FixupCol(CAR(args), 0)); args = CDR(args);
2711 maechler 1421 
    ncol = LENGTH(col);
2 r 1422 
 
5507 ihaka 1423 
    PROTECT(bg = FixupCol(CAR(args), NA_INTEGER));	args = CDR(args);
2690 maechler 1424 
    nbg = LENGTH(bg);
2 r 1425 
 
5507 ihaka 1426 
    PROTECT(cex = FixupCex(CAR(args), 1.0));	args = CDR(args);
2690 maechler 1427 
    ncex = LENGTH(cex);
2 r 1428 
 
1502 maechler 1429 
    /* Miscellaneous Graphical Parameters -- e.g., lwd */
648 ihaka 1430 
    GSavePars(dd);
19912 duncan 1431 
    ProcessInlinePars(args, dd, call);
2 r 1432 
 
648 ihaka 1433 
    x = REAL(sx);
1434 
    y = REAL(sy);
2 r 1435 
 
5507 ihaka 1436 
    if (nlty && INTEGER(lty)[0] != NA_INTEGER)
17179 murrell 1437 
	Rf_gpptr(dd)->lty = INTEGER(lty)[0];
2 r 1438 
 
3367 ihaka 1439 
    GMode(1, dd);
5055 pd 1440 
    /* removed by paul 26/5/99 because all clipping now happens in graphics.c
1441 
     * GClip(dd);
1442 
     */
2 r 1443 
 
9940 pd 1444 
    switch(type) {
1445 
    case 'l':
1446 
    case 'o':
2666 maechler 1447 
	/* lines and overplotted lines and points */
17179 murrell 1448 
	Rf_gpptr(dd)->col = INTEGER(col)[0];
648 ihaka 1449 
	xold = NA_REAL;
1450 
	yold = NA_REAL;
1451 
	for (i = 0; i < n; i++) {
1452 
	    xx = x[i];
1453 
	    yy = y[i];
1454 
	    /* do the conversion now to check for non-finite */
1455 
	    GConvert(&xx, &yy, USER, DEVICE, dd);
5107 maechler 1456 
	    if ((R_FINITE(xx) && R_FINITE(yy)) &&
1457 
		!(R_FINITE(xold) && R_FINITE(yold)))
648 ihaka 1458 
		start = i;
5107 maechler 1459 
	    else if ((R_FINITE(xold) && R_FINITE(yold)) &&
1460 
		     !(R_FINITE(xx) && R_FINITE(yy))) {
648 ihaka 1461 
		if (i-start > 1)
1462 
		    GPolyline(i-start, x+start, y+start,
1463 
			      USER, dd);
1464 
	    }
5107 maechler 1465 
	    else if ((R_FINITE(xold) && R_FINITE(yold)) &&
648 ihaka 1466 
		     (i == n-1))
1467 
		GPolyline(n-start, x+start, y+start, USER, dd);
1468 
	    xold = xx;
1469 
	    yold = yy;
2 r 1470 
	}
9940 pd 1471 
	break;
1472 
 
1473 
    case 'b':
1474 
    case 'c': /* broken lines (with points in between if 'b') */
1475 
    {
648 ihaka 1476 
	double d, f;
1477 
	d = GConvertYUnits(0.5, CHARS, INCHES, dd);
17179 murrell 1478 
	Rf_gpptr(dd)->col = INTEGER(col)[0];
648 ihaka 1479 
	xold = NA_REAL;
1480 
	yold = NA_REAL;
1481 
	for (i = 0; i < n; i++) {
1482 
	    xx = x[i];
1483 
	    yy = y[i];
1484 
	    GConvert(&xx, &yy, USER, INCHES, dd);
5107 maechler 1485 
	    if (R_FINITE(xold) && R_FINITE(yold) &&
1486 
		R_FINITE(xx) && R_FINITE(yy)) {
5507 ihaka 1487 
		if ((f = d/hypot(xx-xold, yy-yold)) < 0.5) {
648 ihaka 1488 
		    GLine(xold + f * (xx - xold),
1489 
			  yold + f * (yy - yold),
1490 
			  xx + f * (xold - xx),
1491 
			  yy + f * (yold - yy),
1492 
			  INCHES, dd);
2 r 1493 
		}
648 ihaka 1494 
	    }
1495 
	    xold = xx;
1496 
	    yold = yy;
2 r 1497 
	}
648 ihaka 1498 
    }
9940 pd 1499 
    break;
1500 
 
16482 maechler 1501 
    case 's': /* step function	I */
9940 pd 1502 
    {
648 ihaka 1503 
	double xtemp[3], ytemp[3];
17179 murrell 1504 
	Rf_gpptr(dd)->col = INTEGER(col)[0];
648 ihaka 1505 
	xold = x[0];
1506 
	yold = y[0];
1507 
	GConvert(&xold, &yold, USER, DEVICE, dd);
1508 
	for (i = 1; i < n; i++) {
1509 
	    xx = x[i];
1510 
	    yy = y[i];
1511 
	    GConvert(&xx, &yy, USER, DEVICE, dd);
5107 maechler 1512 
	    if (R_FINITE(xold) && R_FINITE(yold) &&
1513 
		R_FINITE(xx) && R_FINITE(yy)) {
648 ihaka 1514 
		xtemp[0] = xold; ytemp[0] = yold;
1515 
		xtemp[1] = xx;	ytemp[1] = yold;
783 maechler 1516 
		xtemp[2] = xx;	ytemp[2] = yy;
648 ihaka 1517 
		GPolyline(3, xtemp, ytemp, DEVICE, dd);
1518 
	    }
1519 
	    xold = xx;
1520 
	    yold = yy;
2 r 1521 
	}
648 ihaka 1522 
    }
9940 pd 1523 
    break;
1524 
 
16482 maechler 1525 
    case 'S': /* step function	II */
9940 pd 1526 
    {
648 ihaka 1527 
	double xtemp[3], ytemp[3];
17179 murrell 1528 
	Rf_gpptr(dd)->col = INTEGER(col)[0];
648 ihaka 1529 
	xold = x[0];
1530 
	yold = y[0];
1531 
	GConvert(&xold, &yold, USER, DEVICE, dd);
1532 
	for (i = 1; i < n; i++) {
1533 
	    xx = x[i];
1534 
	    yy = y[i];
1535 
	    GConvert(&xx, &yy, USER, DEVICE, dd);
5107 maechler 1536 
	    if (R_FINITE(xold) && R_FINITE(yold) &&
1537 
		R_FINITE(xx) && R_FINITE(yy)) {
648 ihaka 1538 
		xtemp[0] = xold; ytemp[0] = yold;
1539 
		xtemp[1] = xold; ytemp[1] = yy;
1540 
		xtemp[2] = xx; ytemp[2] = yy;
1541 
		GPolyline(3, xtemp, ytemp, DEVICE, dd);
1542 
	    }
1543 
	    xold = xx;
1544 
	    yold = yy;
2 r 1545 
	}
648 ihaka 1546 
    }
9940 pd 1547 
    break;
1548 
 
1549 
    case 'h': /* h[istogram] (bar plot) */
17179 murrell 1550 
	if (Rf_gpptr(dd)->ylog)
1551 
	    yold = Rf_gpptr(dd)->usr[2];/* DBL_MIN fails.. why ???? */
3279 pd 1552 
	else
1553 
	    yold = 0.0;
1554 
	yold = GConvertY(yold, USER, DEVICE, dd);
648 ihaka 1555 
	for (i = 0; i < n; i++) {
1556 
	    xx = x[i];
1557 
	    yy = y[i];
1558 
	    GConvert(&xx, &yy, USER, DEVICE, dd);
12778 pd 1559 
	    if (R_FINITE(xx) && R_FINITE(yy)
30691 murdoch 1560 
		&& !R_TRANSPARENT(thiscol = INTEGER(col)[i % ncol])) {
17179 murrell 1561 
		Rf_gpptr(dd)->col = thiscol;
3279 pd 1562 
		GLine(xx, yold, xx, yy, DEVICE, dd);
648 ihaka 1563 
	    }
2 r 1564 
	}
9940 pd 1565 
	break;
1566 
 
1567 
    case 'p':
1568 
    case 'n': /* nothing here */
1569 
	break;
1570 
 
1571 
    default:/* OTHERWISE */
1572 
	errorcall(call, "invalid plot type '%c'", type);
1573 
 
10217 pd 1574 
    } /* End {switch(type)} */
9940 pd 1575 
 
648 ihaka 1576 
    if (type == 'p' || type == 'b' || type == 'o') {
1577 
	for (i = 0; i < n; i++) {
1578 
	    xx = x[i];
1579 
	    yy = y[i];
1580 
	    GConvert(&xx, &yy, USER, DEVICE, dd);
5107 maechler 1581 
	    if (R_FINITE(xx) && R_FINITE(yy)) {
7081 pd 1582 
		if (R_FINITE(thiscex = REAL(cex)[i % ncex])
6994 pd 1583 
		    && (thispch = INTEGER(pch)[i % npch]) != NA_INTEGER
30691 murdoch 1584 
		    && !R_TRANSPARENT(thiscol = INTEGER(col)[i % ncol]))
6994 pd 1585 
		{
17179 murrell 1586 
		    Rf_gpptr(dd)->cex = thiscex * Rf_gpptr(dd)->cexbase;
1587 
		    Rf_gpptr(dd)->col = thiscol;
1588 
		    Rf_gpptr(dd)->bg = INTEGER(bg)[i % nbg];
6994 pd 1589 
		    GSymbol(xx, yy, DEVICE, thispch, dd);
1590 
		}
648 ihaka 1591 
	    }
2 r 1592 
	}
648 ihaka 1593 
    }
3367 ihaka 1594 
    GMode(0, dd);
648 ihaka 1595 
    GRestorePars(dd);
1596 
    UNPROTECT(5);
1597 
    /* NOTE: only record operation if no "error"  */
11067 maechler 1598 
    if (GRecording(call))
648 ihaka 1599 
	recordGraphicOperation(op, originalArgs, dd);
1600 
    return R_NilValue;
10886 maechler 1601 
}/* do_plot_xy */
2 r 1602 
 
676 ihaka 1603 
/* Checks for ... , x0, y0, x1, y1 ... */
581 paul 1604 
 
2 r 1605 
static void xypoints(SEXP call, SEXP args, int *n)
1606 
{
987 maechler 1607 
    int k=0;/* -Wall */
2 r 1608 
 
648 ihaka 1609 
    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
5731 ripley 1610 
	errorcall(call, "first argument invalid");
10172 luke 1611 
    SETCAR(args, coerceVector(CAR(args), REALSXP));
648 ihaka 1612 
    *n = k;
1613 
    args = CDR(args);
2 r 1614 
 
648 ihaka 1615 
    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
5731 ripley 1616 
	errorcall(call, "second argument invalid");
10172 luke 1617 
    SETCAR(args, coerceVector(CAR(args), REALSXP));
648 ihaka 1618 
    if (k > *n) *n = k;
1619 
    args = CDR(args);
2 r 1620 
 
648 ihaka 1621 
    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
5731 ripley 1622 
	errorcall(call, "third argument invalid");
10172 luke 1623 
    SETCAR(args, coerceVector(CAR(args), REALSXP));
648 ihaka 1624 
    if (k > *n) *n = k;
1625 
    args = CDR(args);
2 r 1626 
 
648 ihaka 1627 
    if (!isNumeric(CAR(args)) || (k = LENGTH(CAR(args))) <= 0)
5731 ripley 1628 
	errorcall(call, "fourth argument invalid");
10172 luke 1629 
    SETCAR(args, coerceVector(CAR(args), REALSXP));
648 ihaka 1630 
    if (k > *n) *n = k;
1631 
    args = CDR(args);
2 r 1632 
}
1633 
 
1634 
 
1635 
SEXP do_segments(SEXP call, SEXP op, SEXP args, SEXP env)
1636 
{
7081 pd 1637 
    /* segments(x0, y0, x1, y1, col, lty, lwd, ...) */
1502 maechler 1638 
    SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
648 ihaka 1639 
    double *x0, *x1, *y0, *y1;
1640 
    double xx[2], yy[2];
3875 hornik 1641 
    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
648 ihaka 1642 
    SEXP originalArgs = args;
1643 
    DevDesc *dd = CurrentDevice();
2 r 1644 
 
6191 maechler 1645 
    if (length(args) < 4) errorcall(call, "too few arguments");
648 ihaka 1646 
    GCheckState(dd);
2 r 1647 
 
648 ihaka 1648 
    xypoints(call, args, &n);
2 r 1649 
 
648 ihaka 1650 
    sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);
1651 
    sy0 = CAR(args); ny0 = length(sy0); args = CDR(args);
1652 
    sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
1653 
    sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);
2 r 1654 
 
5507 ihaka 1655 
    PROTECT(col = FixupCol(CAR(args), NA_INTEGER));
3506 r 1656 
    ncol = LENGTH(col); args = CDR(args);
1365 maechler 1657 
 
17179 murrell 1658 
    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));
3506 r 1659 
    nlty = length(lty); args = CDR(args);
2 r 1660 
 
17179 murrell 1661 
    PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
3506 r 1662 
    nlwd = length(lwd); args = CDR(args);
1502 maechler 1663 
 
648 ihaka 1664 
    GSavePars(dd);
19912 duncan 1665 
    ProcessInlinePars(args, dd, call);
2 r 1666 
 
648 ihaka 1667 
    x0 = REAL(sx0);
1668 
    y0 = REAL(sy0);
1669 
    x1 = REAL(sx1);
1670 
    y1 = REAL(sy1);
2 r 1671 
 
3367 ihaka 1672 
    GMode(1, dd);
648 ihaka 1673 
    for (i = 0; i < n; i++) {
1674 
	xx[0] = x0[i%nx0];
1675 
	yy[0] = y0[i%ny0];
1676 
	xx[1] = x1[i%nx1];
1677 
	yy[1] = y1[i%ny1];
1678 
	GConvert(xx, yy, USER, DEVICE, dd);
1679 
	GConvert(xx+1, yy+1, USER, DEVICE, dd);
5491 ihaka 1680 
	if (R_FINITE(xx[0]) && R_FINITE(yy[0]) &&
1681 
	    R_FINITE(xx[1]) && R_FINITE(yy[1]))
1682 
	{
17179 murrell 1683 
	    Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
16482 maechler 1684 
	    /* NA color should be ok */
17179 murrell 1685 
	    Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
1686 
	    Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
648 ihaka 1687 
	    GLine(xx[0], yy[0], xx[1], yy[1], DEVICE, dd);
2 r 1688 
	}
648 ihaka 1689 
    }
3367 ihaka 1690 
    GMode(0, dd);
648 ihaka 1691 
    GRestorePars(dd);
2 r 1692 
 
1502 maechler 1693 
    UNPROTECT(3);
648 ihaka 1694 
    /* NOTE: only record operation if no "error"  */
11067 maechler 1695 
    if (GRecording(call))
648 ihaka 1696 
	recordGraphicOperation(op, originalArgs, dd);
1697 
    return R_NilValue;
2 r 1698 
}
1699 
 
1700 
 
1701 
SEXP do_rect(SEXP call, SEXP op, SEXP args, SEXP env)
1702 
{
20358 ripley 1703 
    /* rect(xl, yb, xr, yt, col, border, lty, lwd, xpd, ...) */
15168 pd 1704 
    SEXP sxl, sxr, syb, syt, sxpd, col, lty, lwd, border;
648 ihaka 1705 
    double *xl, *xr, *yb, *yt, x0, y0, x1, y1;
7081 pd 1706 
    int i, n, nxl, nxr, nyb, nyt, ncol, nlty, nlwd, nborder, xpd;
648 ihaka 1707 
    SEXP originalArgs = args;
1708 
    DevDesc *dd = CurrentDevice();
2 r 1709 
 
6191 maechler 1710 
    if (length(args) < 4) errorcall(call, "too few arguments");
648 ihaka 1711 
    GCheckState(dd);
2 r 1712 
 
648 ihaka 1713 
    xypoints(call, args, &n);
16482 maechler 1714 
    sxl = CAR(args); nxl = length(sxl); args = CDR(args);/* x_left */
1715 
    syb = CAR(args); nyb = length(syb); args = CDR(args);/* y_bottom */
1716 
    sxr = CAR(args); nxr = length(sxr); args = CDR(args);/* x_right */
1717 
    syt = CAR(args); nyt = length(syt); args = CDR(args);/* y_top */
2 r 1718 
 
8323 ihaka 1719 
    PROTECT(col = FixupCol(CAR(args), NA_INTEGER));
648 ihaka 1720 
    ncol = LENGTH(col);
8323 ihaka 1721 
    args = CDR(args);
2 r 1722 
 
17187 ripley 1723 
    PROTECT(border =  FixupCol(CAR(args), Rf_gpptr(dd)->fg));
648 ihaka 1724 
    nborder = LENGTH(border);
8323 ihaka 1725 
    args = CDR(args);
2 r 1726 
 
17179 murrell 1727 
    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));
648 ihaka 1728 
    nlty = length(lty);
8323 ihaka 1729 
    args = CDR(args);
2 r 1730 
 
17179 murrell 1731 
    PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd));
7081 pd 1732 
    nlwd = length(lwd);
8323 ihaka 1733 
    args = CDR(args);
7081 pd 1734 
 
15168 pd 1735 
    sxpd = CAR(args);
1736 
    if (sxpd != R_NilValue)
1737 
	xpd = asInteger(sxpd);
1738 
    else
17179 murrell 1739 
	xpd = Rf_gpptr(dd)->xpd;
8323 ihaka 1740 
    args = CDR(args);
987 maechler 1741 
 
648 ihaka 1742 
    GSavePars(dd);
20358 ripley 1743 
    ProcessInlinePars(args, dd, call);
2 r 1744 
 
5055 pd 1745 
    if (xpd == NA_INTEGER)
17179 murrell 1746 
	Rf_gpptr(dd)->xpd = 2;
5055 pd 1747 
    else
17179 murrell 1748 
	Rf_gpptr(dd)->xpd = xpd;
2 r 1749 
 
648 ihaka 1750 
    xl = REAL(sxl);
1751 
    xr = REAL(sxr);
1752 
    yb = REAL(syb);
1753 
    yt = REAL(syt);
2 r 1754 
 
3367 ihaka 1755 
    GMode(1, dd);
648 ihaka 1756 
    for (i = 0; i < n; i++) {
987 maechler 1757 
	if (nlty && INTEGER(lty)[i % nlty] != NA_INTEGER)
17179 murrell 1758 
	    Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
987 maechler 1759 
	else
17179 murrell 1760 
	    Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
7081 pd 1761 
	if (nlwd && REAL(lwd)[i % nlwd] != NA_REAL)
17179 murrell 1762 
	    Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
7081 pd 1763 
	else
17179 murrell 1764 
	    Rf_gpptr(dd)->lwd = Rf_dpptr(dd)->lwd;
648 ihaka 1765 
	x0 = xl[i%nxl];
1766 
	y0 = yb[i%nyb];
1767 
	x1 = xr[i%nxr];
1768 
	y1 = yt[i%nyt];
1769 
	GConvert(&x0, &y0, USER, DEVICE, dd);
1770 
	GConvert(&x1, &y1, USER, DEVICE, dd);
5107 maechler 1771 
	if (R_FINITE(x0) && R_FINITE(y0) && R_FINITE(x1) && R_FINITE(y1))
648 ihaka 1772 
	    GRect(x0, y0, x1, y1, DEVICE, INTEGER(col)[i % ncol],
1773 
		  INTEGER(border)[i % nborder], dd);
1774 
    }
3367 ihaka 1775 
    GMode(0, dd);
2 r 1776 
 
648 ihaka 1777 
    GRestorePars(dd);
7081 pd 1778 
    UNPROTECT(4);
648 ihaka 1779 
    /* NOTE: only record operation if no "error"  */
11067 maechler 1780 
    if (GRecording(call))
648 ihaka 1781 
	recordGraphicOperation(op, originalArgs, dd);
1782 
    return R_NilValue;
2 r 1783 
}
1784 
 
1785 
 
1786 
SEXP do_arrows(SEXP call, SEXP op, SEXP args, SEXP env)
1787 
{
1502 maechler 1788 
    /* arrows(x0, y0, x1, y1, length, angle, code, col, lty, lwd, xpd) */
30691 murdoch 1789 
    SEXP sx0, sx1, sy0, sy1, sxpd, col, rawcol, lty, lwd;
648 ihaka 1790 
    double *x0, *x1, *y0, *y1;
1365 maechler 1791 
    double xx0, yy0, xx1, yy1;
1792 
    double hlength, angle;
1793 
    int code;
1502 maechler 1794 
    int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd, xpd;
648 ihaka 1795 
    SEXP originalArgs = args;
1796 
    DevDesc *dd = CurrentDevice();
2 r 1797 
 
6191 maechler 1798 
    if (length(args) < 4) errorcall(call, "too few arguments");
648 ihaka 1799 
    GCheckState(dd);
2 r 1800 
 
648 ihaka 1801 
    xypoints(call, args, &n);
2 r 1802 
 
648 ihaka 1803 
    sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);
1804 
    sy0 = CAR(args); ny0 = length(sy0); args = CDR(args);
1805 
    sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
1806 
    sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);
2 r 1807 
 
8323 ihaka 1808 
    hlength = asReal(CAR(args));
15973 ripley 1809 
    if (!R_FINITE(hlength) || hlength < 0)
6191 maechler 1810 
	errorcall(call, "invalid head length");
8323 ihaka 1811 
    args = CDR(args);
2 r 1812 
 
8323 ihaka 1813 
    angle = asReal(CAR(args));
5107 maechler 1814 
    if (!R_FINITE(angle))
6191 maechler 1815 
	errorcall(call, "invalid head angle");
8323 ihaka 1816 
    args = CDR(args);
2 r 1817 
 
8323 ihaka 1818 
    code = asInteger(CAR(args));
648 ihaka 1819 
    if (code == NA_INTEGER || code < 0 || code > 3)
5731 ripley 1820 
	errorcall(call, "invalid arrow head specification");
8323 ihaka 1821 
    args = CDR(args);
2 r 1822 
 
30691 murdoch 1823 
    /*
1824 
     * Need raw colours to be able to check for NAs
1825 
     * FixupCol converts NAs to fully transparent
1826 
     */
1827 
    rawcol = CAR(args);
1828 
    PROTECT(col = FixupCol(rawcol, NA_INTEGER));
648 ihaka 1829 
    ncol = LENGTH(col);
8323 ihaka 1830 
    args = CDR(args);
2 r 1831 
 
17179 murrell 1832 
    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));
648 ihaka 1833 
    nlty = length(lty);
8323 ihaka 1834 
    args = CDR(args);
2 r 1835 
 
8323 ihaka 1836 
    PROTECT(lwd = CAR(args));/*need  FixupLwd ?*/
1502 maechler 1837 
    nlwd = length(lwd);
5507 ihaka 1838 
    if (nlwd == 0)
1502 maechler 1839 
	errorcall(call, "'lwd' must be numeric of length >=1");
8323 ihaka 1840 
    args = CDR(args);
1502 maechler 1841 
 
15168 pd 1842 
    sxpd = CAR(args);
1843 
    if (sxpd != R_NilValue)
1844 
	xpd = asInteger(sxpd);
1845 
    else
17179 murrell 1846 
	xpd = Rf_gpptr(dd)->xpd;
8323 ihaka 1847 
    args = CDR(args);
5107 maechler 1848 
 
648 ihaka 1849 
    GSavePars(dd);
2 r 1850 
 
5055 pd 1851 
    if (xpd == NA_INTEGER)
17179 murrell 1852 
	Rf_gpptr(dd)->xpd = 2;
5055 pd 1853 
    else
17179 murrell 1854 
	Rf_gpptr(dd)->xpd = xpd;
987 maechler 1855 
 
648 ihaka 1856 
    x0 = REAL(sx0);
1857 
    y0 = REAL(sy0);
1858 
    x1 = REAL(sx1);
1859 
    y1 = REAL(sy1);
2 r 1860 
 
3367 ihaka 1861 
    GMode(1, dd);
648 ihaka 1862 
    for (i = 0; i < n; i++) {
1863 
	xx0 = x0[i%nx0];
1864 
	yy0 = y0[i%ny0];
1865 
	xx1 = x1[i%nx1];
1866 
	yy1 = y1[i%ny1];
1867 
	GConvert(&xx0, &yy0, USER, DEVICE, dd);
1868 
	GConvert(&xx1, &yy1, USER, DEVICE, dd);
5107 maechler 1869 
	if (R_FINITE(xx0) && R_FINITE(yy0) && R_FINITE(xx1) && R_FINITE(yy1)) {
30691 murdoch 1870 
	    if (isNAcol(rawcol, i, ncol))
17179 murrell 1871 
		Rf_gpptr(dd)->col = Rf_dpptr(dd)->col;
30691 murdoch 1872 
	    else
1873 
		Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
5507 ihaka 1874 
	    if (nlty == 0 || INTEGER(lty)[i % nlty] == NA_INTEGER)
17179 murrell 1875 
		Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
648 ihaka 1876 
	    else
17179 murrell 1877 
		Rf_gpptr(dd)->lty = INTEGER(lty)[i % nlty];
1878 
	    Rf_gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
648 ihaka 1879 
	    GArrow(xx0, yy0, xx1, yy1, DEVICE,
1880 
		   hlength, angle, code, dd);
2 r 1881 
	}
648 ihaka 1882 
    }
3367 ihaka 1883 
    GMode(0, dd);
1365 maechler 1884 
    GRestorePars(dd);
2 r 1885 
 
1502 maechler 1886 
    UNPROTECT(3);
648 ihaka 1887 
    /* NOTE: only record operation if no "error"  */
11067 maechler 1888 
    if (GRecording(call))
648 ihaka 1889 
	recordGraphicOperation(op, originalArgs, dd);
1890 
    return R_NilValue;
2 r 1891 
}
1892 
 
1893 
 
16482 maechler 1894 
static void drawPolygon(int n, double *x, double *y,
12976 pd 1895 
			int lty, int fill, int border, DevDesc *dd)
1896 
{
1897 
    if (lty == NA_INTEGER)
17179 murrell 1898 
	Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
12976 pd 1899 
    else
17179 murrell 1900 
	Rf_gpptr(dd)->lty = lty;
12976 pd 1901 
    GPolygon(n, x, y, USER, fill, border, dd);
1902 
}
1903 
 
2 r 1904 
SEXP do_polygon(SEXP call, SEXP op, SEXP args, SEXP env)
1905 
{
10217 pd 1906 
    /* polygon(x, y, col, border, lty, xpd, ...) */
5055 pd 1907 
    SEXP sx, sy, col, border, lty, sxpd;
10217 pd 1908 
    int nx;
1909 
    int ncol, nborder, nlty, xpd, i, start=0;
3224 r 1910 
    int num = 0;
1648 pd 1911 
    double *x, *y, xx, yy, xold, yold;
987 maechler 1912 
 
648 ihaka 1913 
    SEXP originalArgs = args;
1914 
    DevDesc *dd = CurrentDevice();
2 r 1915 
 
648 ihaka 1916 
    GCheckState(dd);
2 r 1917 
 
6191 maechler 1918 
    if (length(args) < 2) errorcall(call, "too few arguments");
10217 pd 1919 
    /* (x,y) is checked in R via xy.coords() ; no need here : */
1920 
    sx = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
1921 
    sy = SETCAR(args, coerceVector(CAR(args), REALSXP));  args = CDR(args);
1922 
    nx = LENGTH(sx);
2 r 1923 
 
10217 pd 1924 
    PROTECT(col = FixupCol(CAR(args), NA_INTEGER));	args = CDR(args);
648 ihaka 1925 
    ncol = LENGTH(col);
2 r 1926 
 
17179 murrell 1927 
    PROTECT(border = FixupCol(CAR(args), Rf_gpptr(dd)->fg));	args = CDR(args);
648 ihaka 1928 
    nborder = LENGTH(border);
2 r 1929 
 
17179 murrell 1930 
    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty));	args = CDR(args);
648 ihaka 1931 
    nlty = length(lty);
2 r 1932 
 
8323 ihaka 1933 
    sxpd = CAR(args);
5055 pd 1934 
    if (sxpd != R_NilValue)
1935 
	xpd = asInteger(sxpd);
1936 
    else
17179 murrell 1937 
	xpd = Rf_gpptr(dd)->xpd;
8323 ihaka 1938 
    args = CDR(args);
2 r 1939 
 
648 ihaka 1940 
    GSavePars(dd);
19912 duncan 1941 
    ProcessInlinePars(args, dd, call);
2 r 1942 
 
5055 pd 1943 
    if (xpd == NA_INTEGER)
17179 murrell 1944 
	Rf_gpptr(dd)->xpd = 2;
5055 pd 1945 
    else
17179 murrell 1946 
	Rf_gpptr(dd)->xpd = xpd;
5055 pd 1947 
 
3367 ihaka 1948 
    GMode(1, dd);
2 r 1949 
 
1648 pd 1950 
    x = REAL(sx);
1951 
    y = REAL(sy);
1952 
    xold = NA_REAL;
1953 
    yold = NA_REAL;
5507 ihaka 1954 
    for (i = 0; i < nx; i++) {
1648 pd 1955 
	xx = x[i];
1956 
	yy = y[i];
1957 
	GConvert(&xx, &yy, USER, DEVICE, dd);
5107 maechler 1958 
	if ((R_FINITE(xx) && R_FINITE(yy)) &&
1959 
	    !(R_FINITE(xold) && R_FINITE(yold)))
3797 r 1960 
	    start = i; /* first point of current segment */
5107 maechler 1961 
	else if ((R_FINITE(xold) && R_FINITE(yold)) &&
1962 
		 !(R_FINITE(xx) && R_FINITE(yy))) {
3224 r 1963 
	    if (i-start > 1) {
16482 maechler 1964 
		drawPolygon(i-start, x+start, y+start,
12976 pd 1965 
			    INTEGER(lty)[num%nlty],
16482 maechler 1966 
			    INTEGER(col)[num%ncol],
12976 pd 1967 
			    INTEGER(border)[num%nborder], dd);
3224 r 1968 
		num++;
1969 
	    }
1648 pd 1970 
	}
5107 maechler 1971 
	else if ((R_FINITE(xold) && R_FINITE(yold)) && (i == nx-1)) { /* last */
16482 maechler 1972 
	    drawPolygon(nx-start, x+start, y+start,
12976 pd 1973 
			INTEGER(lty)[num%nlty],
16482 maechler 1974 
			INTEGER(col)[num%ncol],
12976 pd 1975 
			INTEGER(border)[num%nborder], dd);
3224 r 1976 
	    num++;
1977 
	}
1648 pd 1978 
	xold = xx;
1979 
	yold = yy;
1980 
    }
581 paul 1981 
 
3367 ihaka 1982 
    GMode(0, dd);
581 paul 1983 
 
648 ihaka 1984 
    GRestorePars(dd);
1985 
    UNPROTECT(3);
1986 
    /* NOTE: only record operation if no "error"  */
11067 maechler 1987 
    if (GRecording(call))
648 ihaka 1988 
	recordGraphicOperation(op, originalArgs, dd);
1989 
    return R_NilValue;
2 r 1990 
}
1991 
 
1992 
SEXP do_text(SEXP call, SEXP op, SEXP args, SEXP env)
1993 
{
10217 pd 1994 
/* text(xy, labels, adj, pos, offset,
1995 
 *	vfont, cex, col, font, xpd, ...)
1996 
 */
30691 murdoch 1997 
    SEXP sx, sy, sxy, sxpd, txt, adj, pos, cex, col, rawcol, font, vfont;
10217 pd 1998 
    int i, n, npos, ncex, ncol, nfont, ntxt, xpd;
4443 ihaka 1999 
    double adjx = 0, adjy = 0, offset = 0.5;
648 ihaka 2000 
    double *x, *y;
2001 
    double xx, yy;
10886 maechler 2002 
    Rboolean vectorFonts = FALSE;
18933 ripley 2003 
    SEXP string, originalArgs = args;
648 ihaka 2004 
    DevDesc *dd = CurrentDevice();
2 r 2005 
 
648 ihaka 2006 
    GCheckState(dd);
2 r 2007 
 
6191 maechler 2008 
    if (length(args) < 3) errorcall(call, "too few arguments");
2 r 2009 
 
10217 pd 2010 
    PLOT_XY_DEALING("text");
3786 pd 2011 
 
10886 maechler 2012 
    /* labels */
648 ihaka 2013 
    txt = CAR(args);
10217 pd 2014 
    if (isSymbol(txt) || isLanguage(txt))
2015 
	txt = coerceVector(txt, EXPRSXP);
2016 
    else if (!isExpression(txt))
9291 ihaka 2017 
	txt = coerceVector(txt, STRSXP);
2018 
    PROTECT(txt);
2019 
    if (length(txt) <= 0)
30691 murdoch 2020 
	errorcall(call, "zero length 'labels'");
648 ihaka 2021 
    args = CDR(args);
2 r 2022 
 
1436 ihaka 2023 
    PROTECT(adj = CAR(args));
5507 ihaka 2024 
    if (isNull(adj) || (isNumeric(adj) && length(adj) == 0)) {
17179 murrell 2025 
	adjx = Rf_gpptr(dd)->adj;
3682 r 2026 
	adjy = NA_REAL;
648 ihaka 2027 
    }
5507 ihaka 2028 
    else if (isReal(adj)) {
2029 
	if (LENGTH(adj) == 1) {
648 ihaka 2030 
	    adjx = REAL(adj)[0];
3682 r 2031 
	    adjy = NA_REAL;
2 r 2032 
	}
648 ihaka 2033 
	else {
2034 
	    adjx = REAL(adj)[0];
2035 
	    adjy = REAL(adj)[1];
2 r 2036 
	}
648 ihaka 2037 
    }
15508 pd 2038 
    else if (isInteger(adj)) {
2039 
	if (LENGTH(adj) == 1) {
2040 
	    adjx = INTEGER(adj)[0];
2041 
	    adjy = NA_REAL;
2042 
	}
2043 
	else {
2044 
	    adjx = INTEGER(adj)[0];
2045 
	    adjy = INTEGER(adj)[1];
2046 
	}
2047 
    }
5731 ripley 2048 
    else errorcall(call, "invalid adj value");
1436 ihaka 2049 
    args = CDR(args);
2 r 2050 
 
4443 ihaka 2051 
    PROTECT(pos = coerceVector(CAR(args), INTSXP));
10217 pd 2052 
    npos = length(pos);
2053 
    for (i = 0; i < npos; i++)
16482 maechler 2054 
	if (INTEGER(pos)[i] < 1 || INTEGER(pos)[i] > 4)
6191 maechler 2055 
	    errorcall(call, "invalid pos value");
4443 ihaka 2056 
    args = CDR(args);
2057 
 
2058 
    offset = GConvertXUnits(asReal(CAR(args)), CHARS, INCHES, dd);
2059 
    args = CDR(args);
2060 
 
7812 murrell 2061 
    PROTECT(vfont = FixupVFont(CAR(args)));
7986 maechler 2062 
    if (!isNull(vfont))
10886 maechler 2063 
	vectorFonts = TRUE;
8323 ihaka 2064 
    args = CDR(args);
7812 murrell 2065 
 
8323 ihaka 2066 
    PROTECT(cex = FixupCex(CAR(args), 1.0));
1436 ihaka 2067 
    ncex = LENGTH(cex);
8323 ihaka 2068 
    args = CDR(args);
1436 ihaka 2069 
 
30691 murdoch 2070 
    rawcol = CAR(args);
2071 
    PROTECT(col = FixupCol(rawcol, NA_INTEGER));
1436 ihaka 2072 
    ncol = LENGTH(col);
8323 ihaka 2073 
    args = CDR(args);
1436 ihaka 2074 
 
8323 ihaka 2075 
    PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
1436 ihaka 2076 
    nfont = LENGTH(font);
8323 ihaka 2077 
    args = CDR(args);
1436 ihaka 2078 
 
10217 pd 2079 
    sxpd = CAR(args); /* xpd: NULL -> par("xpd") */
2080 
    if (sxpd != R_NilValue)
2081 
	xpd = asInteger(sxpd);
2082 
    else
17179 murrell 2083 
	xpd = Rf_gpptr(dd)->xpd;
8284 ripley 2084 
    args = CDR(args);
2 r 2085 
 
648 ihaka 2086 
    x = REAL(sx);
2087 
    y = REAL(sy);
2088 
    n = LENGTH(sx);
2089 
    ntxt = LENGTH(txt);
2 r 2090 
 
648 ihaka 2091 
    GSavePars(dd);
19912 duncan 2092 
    ProcessInlinePars(args, dd, call);
282 ihaka 2093 
 
17179 murrell 2094 
    Rf_gpptr(dd)->xpd = (xpd == NA_INTEGER)? 2 : xpd;
10217 pd 2095 
 
3367 ihaka 2096 
    GMode(1, dd);
648 ihaka 2097 
    for (i = 0; i < n; i++) {
2098 
	xx = x[i % n];
2099 
	yy = y[i % n];
4443 ihaka 2100 
	GConvert(&xx, &yy, USER, INCHES, dd);
5107 maechler 2101 
	if (R_FINITE(xx) && R_FINITE(yy)) {
30691 murdoch 2102 
	    if (ncol && !isNAcol(rawcol, i, ncol))
17179 murrell 2103 
		Rf_gpptr(dd)->col = INTEGER(col)[i % ncol];
783 maechler 2104 
	    else
17179 murrell 2105 
		Rf_gpptr(dd)->col = Rf_dpptr(dd)->col;
5507 ihaka 2106 
	    if (ncex && R_FINITE(REAL(cex)[i%ncex]))
17179 murrell 2107 
		Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * REAL(cex)[i % ncex];
783 maechler 2108 
	    else
17179 murrell 2109 
		Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase;
648 ihaka 2110 
	    if (nfont && INTEGER(font)[i % nfont] != NA_INTEGER)
17179 murrell 2111 
		Rf_gpptr(dd)->font = INTEGER(font)[i % nfont];
783 maechler 2112 
	    else
17179 murrell 2113 
		Rf_gpptr(dd)->font = Rf_dpptr(dd)->font;
10217 pd 2114 
	    if (npos > 0) {
2115 
		switch(INTEGER(pos)[i % npos]) {
4443 ihaka 2116 
		case 1:
2117 
		    yy = yy - offset;
2118 
		    adjx = 0.5;
17179 murrell 2119 
		    adjy = 1 - (0.5 - Rf_gpptr(dd)->yCharOffset);
4443 ihaka 2120 
		    break;
2121 
		case 2:
2122 
		    xx = xx - offset;
2123 
		    adjx = 1;
17179 murrell 2124 
		    adjy = Rf_gpptr(dd)->yCharOffset;
4443 ihaka 2125 
		    break;
2126 
		case 3:
2127 
		    yy = yy + offset;
2128 
		    adjx = 0.5;
2129 
		    adjy = 0;
2130 
		    break;
2131 
		case 4:
2132 
		    xx = xx + offset;
2133 
		    adjx = 0;
17179 murrell 2134 
		    adjy = Rf_gpptr(dd)->yCharOffset;
4443 ihaka 2135 
		    break;
2136 
		}
2137 
	    }
18933 ripley 2138 
	    if (vectorFonts) {
2139 
		string = STRING_ELT(txt, i % ntxt);
2140 
		if(string != NA_STRING)
2141 
		    GVText(xx, yy, INCHES, CHAR(string),
2142 
			   INTEGER(vfont)[0], INTEGER(vfont)[1],
2143 
			   adjx, adjy, Rf_gpptr(dd)->srt, dd);
19875 murrell 2144 
	    } else if (isExpression(txt)) {
20197 murrell 2145 
		GMathText(xx, yy, INCHES, VECTOR_ELT(txt, i % ntxt),
2146 
			  adjx, adjy, Rf_gpptr(dd)->srt, dd);
19875 murrell 2147 
	    } else {
18933 ripley 2148 
		string = STRING_ELT(txt, i % ntxt);
2149 
		if(string != NA_STRING)
2150 
		    GText(xx, yy, INCHES, CHAR(string),
2151 
			  adjx, adjy, Rf_gpptr(dd)->srt, dd);
2152 
	    }
2 r 2153 
	}
648 ihaka 2154 
    }
3367 ihaka 2155 
    GMode(0, dd);
2 r 2156 
 
648 ihaka 2157 
    GRestorePars(dd);
9291 ihaka 2158 
    UNPROTECT(7);
648 ihaka 2159 
    /* NOTE: only record operation if no "error"  */
11067 maechler 2160 
    if (GRecording(call))
648 ihaka 2161 
	recordGraphicOperation(op, originalArgs, dd);
2162 
    return R_NilValue;
2 r 2163 
}
2164 
 
4680 ihaka 2165 
static double ComputeAdjValue(double adj, int side, int las)
2 r 2166 
{
5107 maechler 2167 
    if (!R_FINITE(adj)) {
4680 ihaka 2168 
	switch(las) {
3475 pd 2169 
	case 0:/* parallel to axis */
2170 
	    adj = 0.5; break;
2171 
	case 1:/* horizontal */
2172 
	    switch(side) {
2173 
	    case 1:
2174 
	    case 3: adj = 0.5; break;
2175 
	    case 2: adj = 1.0; break;
2176 
	    case 4: adj = 0.0; break;
2177 
	    }
12839 murrell 2178 
	    break;
3475 pd 2179 
	case 2:/* perpendicular to axis */
2180 
	    switch(side) {
2181 
	    case 1:
2182 
	    case 2: adj = 1.0; break;
2183 
	    case 3:
2184 
	    case 4: adj = 0.0; break;
2185 
	    }
12839 murrell 2186 
	    break;
3475 pd 2187 
	case 3:/* vertical */
2188 
	    switch(side) {
2189 
	    case 1: adj = 1.0; break;
2190 
	    case 3: adj = 0.0; break;
2191 
	    case 2:
2192 
	    case 4: adj = 0.5; break;
2193 
	    }
12839 murrell 2194 
	    break;
2 r 2195 
	}
648 ihaka 2196 
    }
4680 ihaka 2197 
    return adj;
2198 
}
2 r 2199 
 
16482 maechler 2200 
static double ComputeAtValueFromAdj(double adj, int side, int outer,
2201 
				    DevDesc *dd)
12839 murrell 2202 
{
13400 hornik 2203 
    double at = 0;		/* -Wall */
12839 murrell 2204 
    switch(side % 2) {
2205 
    case 0:
2206 
	at  = outer ? adj : yNPCtoUsr(adj, dd);
2207 
	break;
2208 
    case 1:
2209 
	at = outer ? adj : xNPCtoUsr(adj, dd);
2210 
	break;
2211 
    }
2212 
    return at;
2213 
}
2214 
 
16482 maechler 2215 
static double ComputeAtValue(double at, double adj,
12839 murrell 2216 
			     int side, int las, int outer,
4680 ihaka 2217 
			     DevDesc *dd)
2218 
{
5507 ihaka 2219 
    if (!R_FINITE(at)) {
12839 murrell 2220 
	/* If the text is parallel to the axis, use "adj" for "at"
2221 
	 * Otherwise, centre the text
2222 
	 */
2223 
	switch(las) {
2224 
	case 0:/* parallel to axis */
2225 
	    at = ComputeAtValueFromAdj(adj, side, outer, dd);
648 ihaka 2226 
	    break;
12839 murrell 2227 
	case 1:/* horizontal */
2228 
	    switch(side) {
2229 
	    case 1:
16482 maechler 2230 
	    case 3:
12839 murrell 2231 
		at = ComputeAtValueFromAdj(adj, side, outer, dd);
2232 
		break;
16482 maechler 2233 
	    case 2:
2234 
	    case 4:
12839 murrell 2235 
		at = outer ? 0.5 : yNPCtoUsr(0.5, dd);
2236 
		break;
2237 
	    }
648 ihaka 2238 
	    break;
12839 murrell 2239 
	case 2:/* perpendicular to axis */
2240 
	    switch(side) {
2241 
	    case 1:
16482 maechler 2242 
	    case 3:
12839 murrell 2243 
		at = outer ? 0.5 : xNPCtoUsr(0.5, dd);
2244 
		break;
2245 
	    case 2:
16482 maechler 2246 
	    case 4:
12839 murrell 2247 
		at = outer ? 0.5 : yNPCtoUsr(0.5, dd);
2248 
		break;
2249 
	    }
2250 
	    break;
2251 
	case 3:/* vertical */
2252 
	    switch(side) {
16482 maechler 2253 
	    case 1:
12839 murrell 2254 
	    case 3:
2255 
		at = outer ? 0.5 : xNPCtoUsr(0.5, dd);
2256 
		break;
2257 
	    case 2:
16482 maechler 2258 
	    case 4:
12839 murrell 2259 
		at = ComputeAtValueFromAdj(adj, side, outer, dd);
2260 
		break;
2261 
	    }
2262 
	    break;
2 r 2263 
	}
648 ihaka 2264 
    }
4680 ihaka 2265 
    return at;
2266 
}
2 r 2267 
 
4680 ihaka 2268 
/* mtext(text,
16482 maechler 2269 
	 side = 3,
2270 
	 line = 0,
4680 ihaka 2271 
	 outer = TRUE,
16482 maechler 2272 
	 at = NA,
2273 
	 adj = NA,
2274 
	 cex = NA,
2275 
	 col = NA,
2276 
	 font = NA,
2277 
	 vfont = NULL,
2278 
	 ...) */
5058 ihaka 2279 
 
4680 ihaka 2280 
SEXP do_mtext(SEXP call, SEXP op, SEXP args, SEXP env)
2281 
{
20377 ripley 2282 
    SEXP text, side, line, outer, at, adj, cex, col, font, vfont, string;
30691 murdoch 2283 
    SEXP rawcol;
4680 ihaka 2284 
    int ntext, nside, nline, nouter, nat, nadj, ncex, ncol, nfont;
10886 maechler 2285 
    Rboolean dirtyplot = FALSE, gpnewsave = FALSE, dpnewsave = FALSE;
2286 
    Rboolean vectorFonts = FALSE;
6222 pd 2287 
    int i, n, fontsave, colsave;
4680 ihaka 2288 
    double cexsave;
2289 
    SEXP originalArgs = args;
2290 
    DevDesc *dd = CurrentDevice();
2 r 2291 
 
4680 ihaka 2292 
    GCheckState(dd);
2 r 2293 
 
5507 ihaka 2294 
    if (length(args) < 9)
6191 maechler 2295 
	errorcall(call, "too few arguments");
2 r 2296 
 
4680 ihaka 2297 
    /* Arg1 : text= */
2298 
    text = CAR(args);
10217 pd 2299 
    if (isSymbol(text) || isLanguage(text))
2300 
	text = coerceVector(text, EXPRSXP);
2301 
    else if (!isExpression(text))
2302 
	text = coerceVector(text, STRSXP);
9291 ihaka 2303 
    PROTECT(text);
4680 ihaka 2304 
    n = ntext = length(text);
2305 
    if (ntext <= 0)
6191 maechler 2306 
	errorcall(call, "zero length \"text\" specified");
4680 ihaka 2307 
    args = CDR(args);
2308 
 
2309 
    /* Arg2 : side= */
2310 
    PROTECT(side = coerceVector(CAR(args), INTSXP));
2311 
    nside = length(side);
6191 maechler 2312 
    if (nside <= 0) errorcall(call, "zero length \"side\" specified");
4680 ihaka 2313 
    if (n < nside) n = nside;
2314 
    args = CDR(args);
2315 
 
2316 
    /* Arg3 : line= */
2317 
    PROTECT(line = coerceVector(CAR(args), REALSXP));
2318 
    nline = length(line);
6191 maechler 2319 
    if (nline <= 0) errorcall(call, "zero length \"line\" specified");
4680 ihaka 2320 
    if (n < nline) n = nline;
2321 
    args = CDR(args);
2322 
 
2323 
    /* Arg4 : outer= */
2324 
    /* outer == NA => outer <- 0 */
5058 ihaka 2325 
    PROTECT(outer = coerceVector(CAR(args), INTSXP));
4680 ihaka 2326 
    nouter = length(outer);
6191 maechler 2327 
    if (nouter <= 0) errorcall(call, "zero length \"outer\" specified");
4680 ihaka 2328 
    if (n < nouter) n = nouter;
2329 
    args = CDR(args);
5107 maechler 2330 
 
4680 ihaka 2331 
    /* Arg5 : at= */
2332 
    PROTECT(at = coerceVector(CAR(args), REALSXP));
2333 
    nat = length(at);
6191 maechler 2334 
    if (nat <= 0) errorcall(call, "zero length \"at\" specified");
4680 ihaka 2335 
    if (n < nat) n = nat;
2336 
    args = CDR(args);
2337 
 
2338 
    /* Arg6 : adj= */
2339 
    PROTECT(adj = coerceVector(CAR(args), REALSXP));
2340 
    nadj = length(adj);
6191 maechler 2341 
    if (nadj <= 0) errorcall(call, "zero length \"adj\" specified");
4680 ihaka 2342 
    if (n < nadj) n = nadj;
2343 
    args = CDR(args);
2344 
 
2345 
    /* Arg7 : cex */
5507 ihaka 2346 
    PROTECT(cex = FixupCex(CAR(args), 1.0));
4680 ihaka 2347 
    ncex = length(cex);
6191 maechler 2348 
    if (ncex <= 0) errorcall(call, "zero length \"cex\" specified");
4680 ihaka 2349 
    if (n < ncex) n = ncex;
2350 
    args = CDR(args);
2351 
 
2352 
    /* Arg8 : col */
30691 murdoch 2353 
    rawcol = CAR(args);
2354 
    PROTECT(col = FixupCol(rawcol, NA_INTEGER));
4680 ihaka 2355 
    ncol = length(col);
6191 maechler 2356 
    if (ncol <= 0) errorcall(call, "zero length \"col\" specified");
4680 ihaka 2357 
    if (n < ncol) n = ncol;
2358 
    args = CDR(args);
2359 
 
2360 
    /* Arg9 : font */
5507 ihaka 2361 
    PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
4680 ihaka 2362 
    nfont = length(font);
6191 maechler 2363 
    if (nfont <= 0) errorcall(call, "zero length \"font\" specified");
4680 ihaka 2364 
    if (n < nfont) n = nfont;
2365 
    args = CDR(args);
2366 
 
10886 maechler 2367 
    /* Arg10 : vfont */
2368 
    PROTECT(vfont = FixupVFont(CAR(args)));
2369 
    if (!isNull(vfont))
2370 
	vectorFonts = TRUE;
2371 
    args = CDR(args);
2372 
 
5294 ihaka 2373 
    GSavePars(dd);
19912 duncan 2374 
    ProcessInlinePars(args, dd, call);
5294 ihaka 2375 
 
4680 ihaka 2376 
    /* If we only scribble in the outer margins, */
2377 
    /* we don't want to mark the plot as dirty. */
5107 maechler 2378 
 
10886 maechler 2379 
    dirtyplot = FALSE;
17179 murrell 2380 
    gpnewsave = Rf_gpptr(dd)->new;
2381 
    dpnewsave = Rf_dpptr(dd)->new;
2382 
    cexsave = Rf_gpptr(dd)->cex;
2383 
    fontsave = Rf_gpptr(dd)->font;
2384 
    colsave = Rf_gpptr(dd)->col;
4680 ihaka 2385 
 
5055 pd 2386 
    /* override par("xpd") and force clipping to figure region */
2387 
    /* NOTE: don't override to _reduce_ clipping region */
17179 murrell 2388 
    if (Rf_gpptr(dd)->xpd < 1)
2389 
	Rf_gpptr(dd)->xpd = 1;
5058 ihaka 2390 
 
5055 pd 2391 
    if (outer) {
17179 murrell 2392 
	gpnewsave = Rf_gpptr(dd)->new;
2393 
	dpnewsave = Rf_dpptr(dd)->new;
5055 pd 2394 
	/* override par("xpd") and force clipping to device region */
17179 murrell 2395 
	Rf_gpptr(dd)->xpd = 2;
5055 pd 2396 
    }
3367 ihaka 2397 
    GMode(1, dd);
4680 ihaka 2398 
 
2399 
    for (i = 0; i < n; i++) {
2400 
	double atval = REAL(at)[i%nat];
2401 
	double adjval = REAL(adj)[i%nadj];
2402 
	double cexval = REAL(cex)[i%ncex];
2403 
	double lineval = REAL(line)[i%nline];
2404 
	int outerval = INTEGER(outer)[i%nouter];
2405 
	int sideval = INTEGER(side)[i%nside];
2406 
	int fontval = INTEGER(font)[i%nfont];
6222 pd 2407 
	int colval = INTEGER(col)[i%ncol];
4680 ihaka 2408 
 
2409 
	if (outerval == NA_INTEGER) outerval = 0;
5123 ihaka 2410 
	/* Note : we ignore any shrinking produced */
16482 maechler 2411 
	/* by mfrow / mfcol specs here.	 I.e. don't */
17179 murrell 2412 
	/* Rf_gpptr(dd)->cexbase. */
2413 
	if (R_FINITE(cexval)) Rf_gpptr(dd)->cex = cexval;
4680 ihaka 2414 
	else cexval = cexsave;
17179 murrell 2415 
	Rf_gpptr(dd)->font = (fontval == NA_INTEGER) ? fontsave : fontval;
30691 murdoch 2416 
	if (isNAcol(rawcol, i, ncol))
2417 
	    Rf_gpptr(dd)->col = colsave;
2418 
	else
2419 
	    Rf_gpptr(dd)->col = colval;
17179 murrell 2420 
	Rf_gpptr(dd)->adj = ComputeAdjValue(adjval, sideval, Rf_gpptr(dd)->las);
2421 
	atval = ComputeAtValue(atval, Rf_gpptr(dd)->adj, sideval, Rf_gpptr(dd)->las,
12839 murrell 2422 
			       outerval, dd);
10886 maechler 2423 
 
2424 
	if (vectorFonts) {
20377 ripley 2425 
	    string = STRING_ELT(text, i%ntext);
10886 maechler 2426 
#ifdef GMV_implemented
20377 ripley 2427 
	    if(string != NA_STRING)
2428 
		GMVText(CHAR(string),
2429 
			INTEGER(vfont)[0], INTEGER(vfont)[1],
21044 maechler 2430 
			sideval, lineval, outerval, atval,
20377 ripley 2431 
			Rf_gpptr(dd)->las, dd);
10886 maechler 2432 
#else
16482 maechler 2433 
	    warningcall(call,"Hershey fonts not yet implemented for mtext()");
20377 ripley 2434 
	    if(string != NA_STRING)
21044 maechler 2435 
		GMtext(CHAR(string), sideval, lineval, outerval, atval,
20377 ripley 2436 
		       Rf_gpptr(dd)->las, dd);
10886 maechler 2437 
#endif
2438 
	}
2439 
	else if (isExpression(text))
10172 luke 2440 
	    GMMathText(VECTOR_ELT(text, i%ntext),
17179 murrell 2441 
		       sideval, lineval, outerval, atval, Rf_gpptr(dd)->las, dd);
20377 ripley 2442 
	else {
2443 
	    string = STRING_ELT(text, i%ntext);
2444 
	    if(string != NA_STRING)
21044 maechler 2445 
		GMtext(CHAR(string), sideval, lineval, outerval, atval,
20377 ripley 2446 
		       Rf_gpptr(dd)->las, dd);
2447 
	}
10886 maechler 2448 
 
16482 maechler 2449 
	if (outerval == 0) dirtyplot = TRUE;
10886 maechler 2450 
    }
3367 ihaka 2451 
    GMode(0, dd);
2 r 2452 
 
648 ihaka 2453 
    GRestorePars(dd);
4680 ihaka 2454 
    if (!dirtyplot) {
17179 murrell 2455 
	Rf_gpptr(dd)->new = gpnewsave;
2456 
	Rf_dpptr(dd)->new = dpnewsave;
1346 paul 2457 
    }
10886 maechler 2458 
    UNPROTECT(10);
4680 ihaka 2459 
 
648 ihaka 2460 
    /* NOTE: only record operation if no "error"  */
11067 maechler 2461 
    if (GRecording(call))
648 ihaka 2462 
	recordGraphicOperation(op, originalArgs, dd);
2463 
    return R_NilValue;
10886 maechler 2464 
}/* do_mtext */
2 r 2465 
 
9291 ihaka 2466 
 
2 r 2467 
SEXP do_title(SEXP call, SEXP op, SEXP args, SEXP env)
2468 
{
10886 maechler 2469 
/* Annotation for plots :
2470 
 
2471 
   title(main, sub, xlab, ylab,
16482 maechler 2472 
	 line, outer,
2473 
	 ...) */
10886 maechler 2474 
 
20377 ripley 2475 
    SEXP Main, xlab, ylab, sub, vfont, string;
9434 ihaka 2476 
    double adj, adjy, cex, offset, line, hpos, vpos, where;
10886 maechler 2477 
    int col, font, outer;
1165 ihaka 2478 
    int i, n;
648 ihaka 2479 
    SEXP originalArgs = args;
2480 
    DevDesc *dd = CurrentDevice();
2 r 2481 
 
648 ihaka 2482 
    GCheckState(dd);
2 r 2483 
 
9434 ihaka 2484 
    if (length(args) < 6) errorcall(call, "too few arguments");
2 r 2485 
 
1171 maechler 2486 
    Main = sub = xlab = ylab = R_NilValue;
2 r 2487 
 
648 ihaka 2488 
    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
1171 maechler 2489 
	Main = CAR(args);
648 ihaka 2490 
    args = CDR(args);
2 r 2491 
 
648 ihaka 2492 
    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
2493 
	sub = CAR(args);
2494 
    args = CDR(args);
2 r 2495 
 
648 ihaka 2496 
    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
2497 
	xlab = CAR(args);
2498 
    args = CDR(args);
2 r 2499 
 
648 ihaka 2500 
    if (CAR(args) != R_NilValue && LENGTH(CAR(args)) > 0)
2501 
	ylab = CAR(args);
2502 
    args = CDR(args);
2 r 2503 
 
9434 ihaka 2504 
    line = asReal(CAR(args));
2505 
    args = CDR(args);
2506 
 
2507 
    outer = asLogical(CAR(args));
2508 
    if (outer == NA_LOGICAL) outer = 0;
9687 pd 2509 
    args = CDR(args);
9434 ihaka 2510 
 
648 ihaka 2511 
    GSavePars(dd);
19912 duncan 2512 
    ProcessInlinePars(args, dd, call);
2 r 2513 
 
5055 pd 2514 
    /* override par("xpd") and force clipping to figure region */
2515 
    /* NOTE: don't override to _reduce_ clipping region */
17179 murrell 2516 
    if (Rf_gpptr(dd)->xpd < 1)
2517 
	Rf_gpptr(dd)->xpd = 1;
9434 ihaka 2518 
    if (outer)
17179 murrell 2519 
	Rf_gpptr(dd)->xpd = 2;
2520 
    adj = Rf_gpptr(dd)->adj;
2 r 2521 
 
3367 ihaka 2522 
    GMode(1, dd);
5507 ihaka 2523 
    if (Main != R_NilValue) {
17179 murrell 2524 
	cex = Rf_gpptr(dd)->cexmain;
2525 
	col = Rf_gpptr(dd)->colmain;
2526 
	font = Rf_gpptr(dd)->fontmain;
9291 ihaka 2527 
	GetTextArg(call, Main, &Main, &col, &cex, &font, &vfont);
17179 murrell 2528 
	Rf_gpptr(dd)->col = col;
2529 
	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
2530 
	Rf_gpptr(dd)->font = font;
9434 ihaka 2531 
	if (outer) {
2532 
	    if (R_FINITE(line)) {
2533 
		vpos = line;
2534 
		adjy = 0;
2535 
	    }
2536 
	    else {
17179 murrell 2537 
		vpos = 0.5 * Rf_gpptr(dd)->oma[2];
9434 ihaka 2538 
		adjy = 0.5;
2539 
	    }
2540 
	    hpos = adj;
2541 
	    where = OMA3;
2542 
	}
2543 
	else {
2544 
	    if (R_FINITE(line)) {
2545 
		vpos = line;
2546 
		adjy = 0;
2547 
	    }
2548 
	    else {
17179 murrell 2549 
		vpos = 0.5 * Rf_gpptr(dd)->mar[2];
9434 ihaka 2550 
		adjy = 0.5;
2551 
	    }
2552 
	    hpos = GConvertX(adj, NPC, USER, dd);
2553 
	    where = MAR3;
2554 
	}
5507 ihaka 2555 
	if (isExpression(Main)) {
20197 murrell 2556 
	    GMathText(hpos, vpos, where, VECTOR_ELT(Main, 0),
2557 
		      adj, 0.5, 0.0, dd);
1165 ihaka 2558 
	}
2559 
	else {
1171 maechler 2560 
	  n = length(Main);
9434 ihaka 2561 
	  offset = 0.5 * (n - 1) + vpos;
20377 ripley 2562 
	  for (i = 0; i < n; i++) {
2563 
		string = STRING_ELT(Main, i);
2564 
		if(string != NA_STRING)
21044 maechler 2565 
		    GText(hpos, offset - i, where, CHAR(string), adj,
20377 ripley 2566 
			  adjy, 0.0, dd);
2567 
	  }
1165 ihaka 2568 
	}
648 ihaka 2569 
    }
5507 ihaka 2570 
    if (sub != R_NilValue) {
17179 murrell 2571 
	cex = Rf_gpptr(dd)->cexsub;
2572 
	col = Rf_gpptr(dd)->colsub;
2573 
	font = Rf_gpptr(dd)->fontsub;
9291 ihaka 2574 
	GetTextArg(call, sub, &sub, &col, &cex, &font, &vfont);
17179 murrell 2575 
	Rf_gpptr(dd)->col = col;
2576 
	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
2577 
	Rf_gpptr(dd)->font = font;
9434 ihaka 2578 
	if (R_FINITE(line))
2579 
	    vpos = line;
2580 
	else
17179 murrell 2581 
	    vpos = Rf_gpptr(dd)->mgp[0] + 1;
9434 ihaka 2582 
	if (outer) {
2583 
	    hpos = adj;
2584 
	    where = 1;
2585 
	}
2586 
	else {
2587 
	    hpos = GConvertX(adj, NPC, USER, dd);
2588 
	    where = 0;
2589 
	}
5507 ihaka 2590 
	if (isExpression(sub))
10172 luke 2591 
	    GMMathText(VECTOR_ELT(sub, 0), 1, vpos, where,
9434 ihaka 2592 
		       hpos, 0, dd);
1291 ihaka 2593 
	else {
1754 pd 2594 
	    n = length(sub);
20377 ripley 2595 
	    for (i = 0; i < n; i++) {
2596 
		string = STRING_ELT(sub, i);
2597 
		if(string != NA_STRING)
2598 
		    GMtext(CHAR(string), 1, vpos, where, hpos, 0, dd);
2599 
	    }
1291 ihaka 2600 
	}
648 ihaka 2601 
    }
5507 ihaka 2602 
    if (xlab != R_NilValue) {
17179 murrell 2603 
	cex = Rf_gpptr(dd)->cexlab;
2604 
	col = Rf_gpptr(dd)->collab;
2605 
	font = Rf_gpptr(dd)->fontlab;
9291 ihaka 2606 
	GetTextArg(call, xlab, &xlab, &col, &cex, &font, &vfont);
17179 murrell 2607 
	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
2608 
	Rf_gpptr(dd)->col = col;
2609 
	Rf_gpptr(dd)->font = font;
9434 ihaka 2610 
	if (R_FINITE(line))
2611 
	    vpos = line;
2612 
	else
17179 murrell 2613 
	    vpos = Rf_gpptr(dd)->mgp[0];
9434 ihaka 2614 
	if (outer) {
2615 
	    hpos = adj;
2616 
	    where = 1;
2617 
	}
2618 
	else {
2619 
	    hpos = GConvertX(adj, NPC, USER, dd);
2620 
	    where = 0;
2621 
	}
5507 ihaka 2622 
	if (isExpression(xlab))
10172 luke 2623 
	    GMMathText(VECTOR_ELT(xlab, 0), 1, vpos, where,
9434 ihaka 2624 
		       hpos, 0, dd);
1291 ihaka 2625 
	else {
2626 
	    n = length(xlab);
20377 ripley 2627 
	    for (i = 0; i < n; i++) {
2628 
		string = STRING_ELT(xlab, i);
2629 
		if(string != NA_STRING)
2630 
		    GMtext(CHAR(string), 1, vpos + i, where, hpos, 0, dd);
2631 
	    }
1291 ihaka 2632 
	}
648 ihaka 2633 
    }
5507 ihaka 2634 
    if (ylab != R_NilValue) {
17179 murrell 2635 
	cex = Rf_gpptr(dd)->cexlab;
2636 
	col = Rf_gpptr(dd)->collab;
2637 
	font = Rf_gpptr(dd)->fontlab;
9291 ihaka 2638 
	GetTextArg(call, ylab, &ylab, &col, &cex, &font, &vfont);
17179 murrell 2639 
	Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * cex;
2640 
	Rf_gpptr(dd)->col = col;
2641 
	Rf_gpptr(dd)->font = font;
9434 ihaka 2642 
	if (R_FINITE(line))
2643 
	    vpos = line;
2644 
	else
17179 murrell 2645 
	    vpos = Rf_gpptr(dd)->mgp[0];
9434 ihaka 2646 
	if (outer) {
2647 
	    hpos = adj;
2648 
	    where = 1;
2649 
	}
2650 
	else {
2651 
	    hpos = GConvertY(adj, NPC, USER, dd);
2652 
	    where = 0;
2653 
	}
5507 ihaka 2654 
	if (isExpression(ylab))
10172 luke 2655 
	    GMMathText(VECTOR_ELT(ylab, 0), 2, vpos, where,
9434 ihaka 2656 
		       hpos, 0, dd);
1291 ihaka 2657 
	else {
2658 
	    n = length(ylab);
20377 ripley 2659 
	    for (i = 0; i < n; i++) {
2660 
		string = STRING_ELT(ylab, i);
2661 
		if(string != NA_STRING)
2662 
		    GMtext(CHAR(string), 2, vpos - i, where, hpos, 0, dd);
2663 
	    }
1365 maechler 2664 
	}
648 ihaka 2665 
    }
3367 ihaka 2666 
    GMode(0, dd);
648 ihaka 2667 
    GRestorePars(dd);
2668 
    /* NOTE: only record operation if no "error"  */
11067 maechler 2669 
    if (GRecording(call))
648 ihaka 2670 
	recordGraphicOperation(op, originalArgs, dd);
2671 
    return R_NilValue;
2 r 2672 
}
2673 
 
5507 ihaka 2674 
 
2675 
/*  abline(a, b, h, v, col, lty, lwd, ...)
16482 maechler 2676 
    draw lines in intercept/slope form.	 */
6098 pd 2677 
 
15168 pd 2678 
static void getxlimits(double *x, DevDesc *dd) {
2679 
    /*
2680 
     * xpd = 0 means clip to current plot region
2681 
     * xpd = 1 means clip to current figure region
2682 
     * xpd = 2 means clip to device region
2683 
     */
17179 murrell 2684 
    switch (Rf_gpptr(dd)->xpd) {
15168 pd 2685 
    case 0:
17179 murrell 2686 
	x[0] = Rf_gpptr(dd)->usr[0];
2687 
	x[1] = Rf_gpptr(dd)->usr[1];
15168 pd 2688 
	break;
2689 
    case 1:
2690 
	x[0] = GConvertX(0, NFC, USER, dd);
2691 
	x[1] = GConvertX(1, NFC, USER, dd);
2692 
	break;
2693 
    case 2:
2694 
	x[0] = GConvertX(0, NDC, USER, dd);
2695 
	x[1] = GConvertX(1, NDC, USER, dd);
2696 
	break;
2697 
    }
2698 
}
2699 
 
2700 
static void getylimits(double *y, DevDesc *dd) {
17179 murrell 2701 
    switch (Rf_gpptr(dd)->xpd) {
15168 pd 2702 
    case 0:
17179 murrell 2703 
	y[0] = Rf_gpptr(dd)->usr[2];
2704 
	y[1] = Rf_gpptr(dd)->usr[3];
15168 pd 2705 
	break;
2706 
    case 1:
2707 
	y[0] = GConvertY(0, NFC, USER, dd);
2708 
	y[1] = GConvertY(1, NFC, USER, dd);
2709 
	break;
2710 
    case 2:
2711 
	y[0] = GConvertY(0, NDC, USER, dd);
2712 
	y[1] = GConvertY(1, NDC, USER, dd);
2713 
	break;
2714 
    }
2715 
}
2716 
 
2 r 2717 
SEXP do_abline(SEXP call, SEXP op, SEXP args, SEXP env)
2718 
{
6265 pd 2719 
    SEXP a, b, h, v, untf, col, lty, lwd;
20612 tlumley 2720 
    int i, ncol, nlines, nlty, nlwd, lstart, lstop;
648 ihaka 2721 
    double aa, bb, x[2], y[2];
2722 
    SEXP originalArgs = args;
2723 
    DevDesc *dd = CurrentDevice();
2 r 2724 
 
648 ihaka 2725 
    GCheckState(dd);
581 paul 2726 
 
6191 maechler 2727 
    if (length(args) < 5) errorcall(call, "too few arguments");
2 r 2728 
 
5507 ihaka 2729 
    if ((a = CAR(args)) != R_NilValue)
10172 luke 2730 
	SETCAR(args, a = coerceVector(a, REALSXP));
648 ihaka 2731 
    args = CDR(args);
2 r 2732 
 
5507 ihaka 2733 
    if ((b = CAR(args)) != R_NilValue)
10172 luke 2734 
	SETCAR(args, b = coerceVector(b, REALSXP));
648 ihaka 2735 
    args = CDR(args);
2 r 2736 
 
5507 ihaka 2737 
    if ((h = CAR(args)) != R_NilValue)
10172 luke 2738 
	SETCAR(args, h = coerceVector(h, REALSXP));
648 ihaka 2739 
    args = CDR(args);
2 r 2740 
 
5507 ihaka 2741 
    if ((v = CAR(args)) != R_NilValue)
10172 luke 2742 
	SETCAR(args, v = coerceVector(v, REALSXP));
648 ihaka 2743 
    args = CDR(args);
7081 pd 2744 
 
6265 pd 2745 
    if ((untf = CAR(args)) != R_NilValue)
10172 luke 2746 
	SETCAR(args, untf = coerceVector(untf, LGLSXP));
6265 pd 2747 
    args = CDR(args);
2 r 2748 
 
6265 pd 2749 
 
5507 ihaka 2750 
    PROTECT(col = FixupCol(CAR(args), NA_INTEGER));	args = CDR(args);
648 ihaka 2751 
    ncol = LENGTH(col);
2 r 2752 
 
19936 maechler 2753 
    PROTECT(lty = FixupLty(CAR(args), Rf_gpptr(dd)->lty)); args = CDR(args);
648 ihaka 2754 
    nlty = length(lty);
2 r 2755 
 
19936 maechler 2756 
    PROTECT(lwd = FixupLwd(CAR(args), Rf_gpptr(dd)->lwd)); args = CDR(args);
5491 ihaka 2757 
    nlwd = length(lwd);
2758 
 
648 ihaka 2759 
    GSavePars(dd);
351 maechler 2760 
 
19912 duncan 2761 
    ProcessInlinePars(args, dd, call);
15168 pd 2762 
 
648 ihaka 2763 
    nlines = 0;
2 r 2764 
 
648 ihaka 2765 
    if (a != R_NilValue) {
2766 
	if (b == R_NilValue) {
2767 
	    if (LENGTH(a) != 2)
5731 ripley 2768 
		errorcall(call, "invalid a=, b= specification");
648 ihaka 2769 
	    aa = REAL(a)[0];
2770 
	    bb = REAL(a)[1];
2771 
	}
2772 
	else {
2773 
	    aa = asReal(a);
2774 
	    bb = asReal(b);
2775 
	}
5107 maechler 2776 
	if (!R_FINITE(aa) || !R_FINITE(bb))
6191 maechler 2777 
	    errorcall(call, "\"a\" and \"b\" must be finite");
17179 murrell 2778 
	Rf_gpptr(dd)->col = INTEGER(col)[0];
2779 
	Rf_gpptr(dd)->lwd = REAL(lwd)[0];
987 maechler 2780 
	if (nlty && INTEGER(lty)[0] != NA_INTEGER)
17179 murrell 2781 
	    Rf_gpptr(dd)->lty = INTEGER(lty)[0];
783 maechler 2782 
	else
17179 murrell 2783 
	    Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
3367 ihaka 2784 
	GMode(1, dd);
15168 pd 2785 
	/* FIXME?
2786 
	 * Seems like the logic here is just draw from xmin to xmax
2787 
	 * and you're guaranteed to draw at least from ymin to ymax
2788 
	 * This MAY cause a problem at some stage when the line being
2789 
	 * drawn is VERY steep -- and the problem is worse now that
2790 
	 * abline will potentially draw to the extents of the device
2791 
	 * (when xpd=NA).  NOTE that R's internal clipping protects the
16482 maechler 2792 
	 * device drivers from stupidly large numbers, BUT there is
15168 pd 2793 
	 * still a risk that we could produce a number which is too
2794 
	 * big for the computer's brain.
2795 
	 * Paul.
20612 tlumley 2796 
	 *
2797 
	 * The problem is worse -- you could get NaN, which at least the
2798 
	 * X11 device coerces to -2^31 <TSL>
15168 pd 2799 
	 */
2800 
	getxlimits(x, dd);
17179 murrell 2801 
	if (R_FINITE(Rf_gpptr(dd)->lwd)) {
2802 
	    if (LOGICAL(untf)[0] == 1 && (Rf_gpptr(dd)->xlog || Rf_gpptr(dd)->ylog)) {
1346 paul 2803 
		double xx[101], yy[101];
2804 
		double xstep = (x[1] - x[0])/100;
5507 ihaka 2805 
		for (i = 0; i < 100; i++) {
5491 ihaka 2806 
		    xx[i] = x[0] + i*xstep;
2807 
		    yy[i] = aa + xx[i] * bb;
1346 paul 2808 
		}
2809 
		xx[100] = x[1];
2810 
		yy[100] = aa + x[1] * bb;
21044 maechler 2811 
 
20612 tlumley 2812 
		/* now get rid of -ve values */
2813 
		lstart=0;lstop=100;
2814 
		if (Rf_gpptr(dd)->xlog){
2815 
			for(;xx[lstart]<=0 && lstart<101;lstart++);
2816 
			for(;xx[lstop]<=0 && lstop>0;lstop--);
2817 
		}
2818 
		if (Rf_gpptr(dd)->ylog){
2819 
			for(;yy[lstart]<=0 && lstart<101;lstart++);
2820 
			for(;yy[lstop]<=0 && lstop>0;lstop--);
2821 
		}
21044 maechler 2822 
 
2823 
 
20612 tlumley 2824 
		GPolyline(lstop-lstart+1, xx+lstart, yy+lstart, USER, dd);
5491 ihaka 2825 
	    }
2826 
	    else {
6265 pd 2827 
		double x0, x1;
2828 
 
17179 murrell 2829 
		x0 = ( Rf_gpptr(dd)->xlog ) ?	log10(x[0]) : x[0];
2830 
		x1 = ( Rf_gpptr(dd)->xlog ) ?	log10(x[1]) : x[1];
6265 pd 2831 
 
2832 
		y[0] = aa + x0 * bb;
2833 
		y[1] = aa + x1 * bb;
2834 
 
17179 murrell 2835 
		if ( Rf_gpptr(dd)->ylog ){
6265 pd 2836 
		    y[0] = pow(10.,y[0]);
2837 
		    y[1] = pow(10.,y[1]);
2838 
		}
2839 
 
1346 paul 2840 
		GLine(x[0], y[0], x[1], y[1], USER, dd);
5491 ihaka 2841 
	    }
648 ihaka 2842 
	}
3367 ihaka 2843 
	GMode(0, dd);
648 ihaka 2844 
	nlines++;
2845 
    }
2846 
    if (h != R_NilValue) {
3367 ihaka 2847 
	GMode(1, dd);
648 ihaka 2848 
	for (i = 0; i < LENGTH(h); i++) {
17179 murrell 2849 
	    Rf_gpptr(dd)->col = INTEGER(col)[nlines % ncol];
987 maechler 2850 
	    if (nlty && INTEGER(lty)[nlines % nlty] != NA_INTEGER)
17179 murrell 2851 
		Rf_gpptr(dd)->lty = INTEGER(lty)[nlines % nlty];
783 maechler 2852 
	    else
17179 murrell 2853 
		Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
2854 
	    Rf_gpptr(dd)->lwd = REAL(lwd)[nlines % nlwd];
648 ihaka 2855 
	    aa = REAL(h)[i];
17179 murrell 2856 
	    if (R_FINITE(aa) && R_FINITE(Rf_gpptr(dd)->lwd)) {
15168 pd 2857 
		getxlimits(x, dd);
648 ihaka 2858 
		y[0] = aa;
2859 
		y[1] = aa;
2860 
		GLine(x[0], y[0], x[1], y[1], USER, dd);
2861 
	    }
2862 
	    nlines++;
2863 
	}
3367 ihaka 2864 
	GMode(0, dd);
648 ihaka 2865 
    }
2866 
    if (v != R_NilValue) {
3367 ihaka 2867 
	GMode(1, dd);
648 ihaka 2868 
	for (i = 0; i < LENGTH(v); i++) {
17179 murrell 2869 
	    Rf_gpptr(dd)->col = INTEGER(col)[nlines % ncol];
987 maechler 2870 
	    if (nlty && INTEGER(lty)[nlines % nlty] != NA_INTEGER)
17179 murrell 2871 
		Rf_gpptr(dd)->lty = INTEGER(lty)[nlines % nlty];
783 maechler 2872 
	    else
17179 murrell 2873 
		Rf_gpptr(dd)->lty = Rf_dpptr(dd)->lty;
2874 
	    Rf_gpptr(dd)->lwd = REAL(lwd)[nlines % nlwd];
648 ihaka 2875 
	    aa = REAL(v)[i];
17179 murrell 2876 
	    if (R_FINITE(aa) && R_FINITE(Rf_gpptr(dd)->lwd)) {
15168 pd 2877 
		getylimits(y, dd);
783 maechler 2878 
		x[0] = aa;
648 ihaka 2879 
		x[1] = aa;
581 paul 2880 
		GLine(x[0], y[0], x[1], y[1], USER, dd);
648 ihaka 2881 
	    }
2882 
	    nlines++;
2 r 2883 
	}
3367 ihaka 2884 
	GMode(0, dd);
648 ihaka 2885 
    }
5491 ihaka 2886 
    UNPROTECT(3);
648 ihaka 2887 
    GRestorePars(dd);
2888 
    /* NOTE: only record operation if no "error"  */
11067 maechler 2889 
    if (GRecording(call))
648 ihaka 2890 
	recordGraphicOperation(op, originalArgs, dd);
2891 
    return R_NilValue;
2 r 2892 
}
2893 
 
2894 
SEXP do_box(SEXP call, SEXP op, SEXP args, SEXP env)
2895 
{
2690 maechler 2896 
/*     box(which="plot", lty="solid", ...)
2897 
       --- which is coded, 1 = plot, 2 = figure, 3 = inner, 4 = outer.
2898 
*/
29428 maechler 2899 
    int which, col;
30691 murdoch 2900 
    SEXP colsxp, fgsxp;
648 ihaka 2901 
    SEXP originalArgs = args;
2902 
    DevDesc *dd = CurrentDevice();
581 paul 2903 
 
648 ihaka 2904 
    GCheckState(dd);
2905 
    GSavePars(dd);
2690 maechler 2906 
    which = asInteger(CAR(args)); args = CDR(args);
5507 ihaka 2907 
    if (which < 1 || which > 4)
6191 maechler 2908 
	errorcall(call, "invalid \"which\" specification");
30691 murdoch 2909 
    /*
2910 
     * If specified non-NA col then use that, else ...
2911 
     *
2912 
     * if specified non-NA fg then use that, else ...
2913 
     *
2914 
     * else use par("col")
2915 
     */
2916 
    col= Rf_gpptr(dd)->col;
19912 duncan 2917 
    ProcessInlinePars(args, dd, call);
30691 murdoch 2918 
    colsxp = getInlinePar(args, "col");
2919 
    if (isNAcol(colsxp, 0, 1)) {
2920 
	fgsxp = getInlinePar(args, "fg");
2921 
	if (isNAcol(fgsxp, 0, 1))
17179 murrell 2922 
	    Rf_gpptr(dd)->col = col;
987 maechler 2923 
	else
17179 murrell 2924 
	    Rf_gpptr(dd)->col = Rf_gpptr(dd)->fg;
875 ihaka 2925 
    }
5055 pd 2926 
    /* override par("xpd") and force clipping to device region */
17179 murrell 2927 
    Rf_gpptr(dd)->xpd = 2;
3367 ihaka 2928 
    GMode(1, dd);
648 ihaka 2929 
    GBox(which, dd);
3367 ihaka 2930 
    GMode(0, dd);
648 ihaka 2931 
    GRestorePars(dd);
2932 
    /* NOTE: only record operation if no "error"  */
11067 maechler 2933 
    if (GRecording(call))
648 ihaka 2934 
	recordGraphicOperation(op, originalArgs, dd);
2935 
    return R_NilValue;
2 r 2936 
}
2937 
 
8345 murrell 2938 
static void drawPointsLines(double xp, double yp, double xold, double yold,
8552 maechler 2939 
			    char type, int first, DevDesc *dd)
8345 murrell 2940 
{
2941 
    if (type == 'p' || type == 'o')
17179 murrell 2942 
	GSymbol(xp, yp, DEVICE, Rf_gpptr(dd)->pch, dd);
8345 murrell 2943 
    if ((type == 'l' || type == 'o') && !first)
2944 
	GLine(xold, yold, xp, yp, DEVICE, dd);
2945 
}
2946 
 
2 r 2947 
SEXP do_locator(SEXP call, SEXP op, SEXP args, SEXP env)
2948 
{
8355 ripley 2949 
    SEXP x, y, nobs, ans, saveans, stype = R_NilValue;
5422 ripley 2950 
    int i, n, type='p';
2951 
    double xp, yp, xold=0, yold=0;
648 ihaka 2952 
    DevDesc *dd = CurrentDevice();
2 r 2953 
 
8345 murrell 2954 
    /* If replaying, just draw the points and lines that were recorded */
2955 
    if (call == R_NilValue) {
2956 
	x = CAR(args); args = CDR(args);
2957 
	y = CAR(args); args = CDR(args);
2958 
	nobs = CAR(args); args = CDR(args);
2959 
	n = INTEGER(nobs)[0];
2960 
	stype = CAR(args); args = CDR(args);
10172 luke 2961 
	type = CHAR(STRING_ELT(stype, 0))[0];
5507 ihaka 2962 
	if (type != 'n') {
5422 ripley 2963 
	    GMode(1, dd);
8345 murrell 2964 
	    for (i=0; i<n; i++) {
2965 
		xp = REAL(x)[i];
2966 
		yp = REAL(y)[i];
2967 
		GConvert(&xp, &yp, USER, DEVICE, dd);
2968 
		drawPointsLines(xp, yp, xold, yold, type, i==0, dd);
2969 
		xold = xp;
2970 
		yold = yp;
2971 
	    }
2972 
	    GMode(0, dd);
5422 ripley 2973 
	}
8355 ripley 2974 
	return R_NilValue;
8345 murrell 2975 
    } else {
2976 
	GCheckState(dd);
2977 
 
2978 
	checkArity(op, args);
2979 
	n = asInteger(CAR(args));
2980 
	if (n <= 0 || n == NA_INTEGER)
2981 
	    error("invalid number of points in locator");
2982 
	args = CDR(args);
2983 
	if (isString(CAR(args)) && LENGTH(CAR(args)) == 1)
2984 
	    stype = CAR(args);
8552 maechler 2985 
	else
8345 murrell 2986 
	    errorcall(call, "invalid plot type");
10172 luke 2987 
	type = CHAR(STRING_ELT(stype, 0))[0];
8345 murrell 2988 
	PROTECT(x = allocVector(REALSXP, n));
2989 
	PROTECT(y = allocVector(REALSXP, n));
2990 
	PROTECT(nobs=allocVector(INTSXP,1));
2991 
	i = 0;
8552 maechler 2992 
 
8345 murrell 2993 
	GMode(2, dd);
2994 
	while (i < n) {
2995 
	    if (!GLocator(&(REAL(x)[i]), &(REAL(y)[i]), USER, dd))
2996 
		break;
2997 
	    if (type != 'n') {
2998 
		GMode(1, dd);
2999 
		xp = REAL(x)[i];
3000 
		yp = REAL(y)[i];
3001 
		GConvert(&xp, &yp, USER, DEVICE, dd);
3002 
		drawPointsLines(xp, yp, xold, yold, type, i==0, dd);
3003 
		GMode(2, dd);
3004 
		xold = xp; yold = yp;
3005 
	    }
3006 
	    i += 1;
3007 
	}
3008 
	GMode(0, dd);
3009 
	INTEGER(nobs)[0] = i;
3010 
	while (i < n) {
3011 
	    REAL(x)[i] = NA_REAL;
3012 
	    REAL(y)[i] = NA_REAL;
3013 
	    i += 1;
3014 
	}
3015 
	PROTECT(ans = allocList(3));
10172 luke 3016 
	SETCAR(ans, x);
3017 
	SETCADR(ans, y);
3018 
	SETCADDR(ans, nobs);
8345 murrell 3019 
	PROTECT(saveans = allocList(4));
10172 luke 3020 
	SETCAR(saveans, x);
3021 
	SETCADR(saveans, y);
3022 
	SETCADDR(saveans, nobs);
3023 
	SETCADDDR(saveans, CAR(args));
8345 murrell 3024 
	/* Record the points and lines that were drawn in the display list */
3025 
	recordGraphicOperation(op, saveans, dd);
3026 
	UNPROTECT(5);
3027 
	return ans;
648 ihaka 3028 
    }
2 r 3029 
}
3030 
 
648 ihaka 3031 
#define THRESHOLD	0.25
3032 
 
8321 murrell 3033 
static void drawLabel(double xi, double yi, int pos, double offset, char *l,
8552 maechler 3034 
		      DevDesc *dd)
8321 murrell 3035 
{
3036 
    switch (pos) {
3037 
    case 4:
3038 
	xi = xi+offset;
8552 maechler 3039 
	GText(xi, yi, INCHES, l, 0.0,
17179 murrell 3040 
	      Rf_gpptr(dd)->yCharOffset, 0.0, dd);
8321 murrell 3041 
	break;
3042 
    case 2:
3043 
	xi = xi-offset;
3044 
	GText(xi, yi, INCHES, l, 1.0,
17179 murrell 3045 
	      Rf_gpptr(dd)->yCharOffset, 0.0, dd);
8321 murrell 3046 
	break;
3047 
    case 3:
3048 
	yi = yi+offset;
3049 
	GText(xi, yi, INCHES, l, 0.5,
3050 
	      0.0, 0.0, dd);
3051 
	break;
3052 
    case 1:
3053 
	yi = yi-offset;
3054 
	GText(xi, yi, INCHES, l, 0.5,
17179 murrell 3055 
	      1-(0.5-Rf_gpptr(dd)->yCharOffset),
8321 murrell 3056 
	      0.0, dd);
3057 
    }
3058 
}
3059 
 
2 r 3060 
SEXP do_identify(SEXP call, SEXP op, SEXP args, SEXP env)
3061 
{
18215 murrell 3062 
    SEXP ans, x, y, l, ind, pos, Offset, draw, saveans;
648 ihaka 3063 
    double xi, yi, xp, yp, d, dmin, offset;
23360 rgentlem 3064 
    int i, imin, k, n, npts, plot, posi, warn;
648 ihaka 3065 
    DevDesc *dd = CurrentDevice();
2 r 3066 
 
8321 murrell 3067 
    /* If we are replaying the display list, then just redraw the
3068 
       labels beside the identified points */
3069 
    if (call == R_NilValue) {
3070 
	ind = CAR(args); args = CDR(args);
3071 
	pos = CAR(args); args = CDR(args);
3072 
	x = CAR(args); args = CDR(args);
3073 
	y = CAR(args); args = CDR(args);
3074 
	Offset = CAR(args); args = CDR(args);
18215 murrell 3075 
	l = CAR(args); args = CDR(args);
3076 
	draw = CAR(args);
8321 murrell 3077 
	n = length(x);
3078 
	for (i=0; i<n; i++) {
19936 maechler 3079 
	    plot = LOGICAL(ind)[i];
18215 murrell 3080 
	    if (LOGICAL(draw)[0] && plot) {
8321 murrell 3081 
		xi = REAL(x)[i];
3082 
		yi = REAL(y)[i];
3083 
		GConvert(&xi, &yi, USER, INCHES, dd);
3084 
		posi = INTEGER(pos)[i];
3085 
		offset = GConvertXUnits(asReal(Offset), CHARS, INCHES, dd);
10172 luke 3086 
		drawLabel(xi, yi, posi, offset, CHAR(STRING_ELT(l, i)), dd);
8321 murrell 3087 
	    }
3088 
	}
3089 
	return R_NilValue;
648 ihaka 3090 
    }
8321 murrell 3091 
    else {
3092 
	GCheckState(dd);
2 r 3093 
 
8321 murrell 3094 
	checkArity(op, args);
3095 
	x = CAR(args);
3096 
	args = CDR(args); y = CAR(args);
3097 
	args = CDR(args); l = CAR(args);
3098 
	args = CDR(args); npts = asInteger(CAR(args));
3099 
	args = CDR(args); plot = asLogical(CAR(args));
3100 
	args = CDR(args); Offset = CAR(args);
3101 
	if (npts <= 0 || npts == NA_INTEGER)
3102 
	    error("invalid number of points in identify");
3103 
	if (!isReal(x) || !isReal(y) || !isString(l) || !isReal(Offset))
3104 
	    errorcall(call, "incorrect argument type");
3105 
	if (LENGTH(x) != LENGTH(y) || LENGTH(x) != LENGTH(l))
3106 
	    errorcall(call, "different argument lengths");
3107 
	n = LENGTH(x);
3108 
	if (n <= 0) {
3109 
	    R_Visible = 0;
3110 
	    return NULL;
648 ihaka 3111 
	}
8552 maechler 3112 
 
8321 murrell 3113 
	offset = GConvertXUnits(asReal(Offset), CHARS, INCHES, dd);
3114 
	PROTECT(ind = allocVector(LGLSXP, n));
3115 
	PROTECT(pos = allocVector(INTSXP, n));
3116 
	for (i = 0; i < n; i++)
3117 
	    LOGICAL(ind)[i] = 0;
8552 maechler 3118 
 
8321 murrell 3119 
	k = 0;
3120 
	GMode(2, dd);
3121 
	while (k < npts) {
3122 
	    if (!GLocator(&xp, &yp, INCHES, dd)) break;
3123 
	    dmin = DBL_MAX;
3124 
	    imin = -1;
3125 
	    for (i = 0; i < n; i++) {
3126 
		xi = REAL(x)[i];
3127 
		yi = REAL(y)[i];
3128 
		GConvert(&xi, &yi, USER, INCHES, dd);
3129 
		if (!R_FINITE(xi) || !R_FINITE(yi)) continue;
3130 
		d = hypot(xp-xi, yp-yi);
3131 
		if (d < dmin) {
3132 
		    imin = i;
3133 
		    dmin = d;
2 r 3134 
		}
648 ihaka 3135 
	    }
23360 rgentlem 3136 
	    /* can't use warning because we want to print immediately  */
3137 
	    /* might want to handle warn=2? */
3138 
	    warn = asInteger(GetOption(install("warn"), R_NilValue));
3139 
	    if (dmin > THRESHOLD) {
3140 
	        if(warn >= 0)
26479 maechler 3141 
		    REprintf("warning: no point with %.2f inches\n",
23360 rgentlem 3142 
                                        THRESHOLD);
3143 
	    }
3144 
	    else if (LOGICAL(ind)[imin]) {
3145 
	        if(warn >= 0 )
3146 
		    REprintf("warning: nearest point already identified\n");
3147 
	    }
648 ihaka 3148 
	    else {
8321 murrell 3149 
		k++;
3150 
		LOGICAL(ind)[imin] = 1;
8552 maechler 3151 
 
8321 murrell 3152 
		xi = REAL(x)[imin];
3153 
		yi = REAL(y)[imin];
3154 
		GConvert(&xi, &yi, USER, INCHES, dd);
3155 
		if (fabs(xp-xi) >= fabs(yp-yi)) {
3156 
		    if (xp >= xi) {
3157 
			INTEGER(pos)[imin] = 4;
3158 
		    }
3159 
		    else {
3160 
			INTEGER(pos)[imin] = 2;
3161 
		    }
648 ihaka 3162 
		}
3163 
		else {
8321 murrell 3164 
		    if (yp >= yi) {
3165 
			INTEGER(pos)[imin] = 3;
3166 
		    }
3167 
		    else {
3168 
			INTEGER(pos)[imin] = 1;
3169 
		    }
648 ihaka 3170 
		}
8552 maechler 3171 
		if (plot)
3172 
		    drawLabel(xi, yi, INTEGER(pos)[imin], offset,
10172 luke 3173 
			      CHAR(STRING_ELT(l, imin)), dd);
648 ihaka 3174 
	    }
2 r 3175 
	}
8321 murrell 3176 
	GMode(0, dd);
3177 
	PROTECT(ans = allocList(2));
10172 luke 3178 
	SETCAR(ans, ind);
3179 
	SETCADR(ans, pos);
18215 murrell 3180 
	PROTECT(saveans = allocList(7));
10172 luke 3181 
	SETCAR(saveans, ind);
3182 
	SETCADR(saveans, pos);
3183 
	SETCADDR(saveans, x);
3184 
	SETCADDDR(saveans, y);
3185 
	SETCAD4R(saveans, Offset);
3186 
	SETCAD4R(CDR(saveans), l);
18215 murrell 3187 
	PROTECT(draw = allocVector(LGLSXP, 1));
3188 
	LOGICAL(draw)[0] = plot;
3189 
	SETCAD4R(CDDR(saveans), draw);
8552 maechler 3190 
 
11067 maechler 3191 
	/* If we are recording, save enough information to be able to
8321 murrell 3192 
	   redraw the text labels beside identified points */
11067 maechler 3193 
	if (GRecording(call))
8321 murrell 3194 
	    recordGraphicOperation(op, saveans, dd);
18215 murrell 3195 
	UNPROTECT(5);
8321 murrell 3196 
 
3197 
	return ans;
648 ihaka 3198 
    }
2 r 3199 
}
3200 
 
30691 murdoch 3201 
/* strheight(str, units)  ||  strwidth(str, units) */
3202 
#define DO_STR_DIM(KIND) 						\
3203 
{									\
3204 
    SEXP ans, str, ch;							\
3205 
    int i, n, units;							\
3206 
    double cex, cexsave;						\
3207 
    DevDesc *dd = CurrentDevice();					\
3208 
									\
3209 
    checkArity(op, args);						\
3210 
    GCheckState(dd);							\
3211 
									\
3212 
    str = CAR(args);							\
3213 
    if (isSymbol(str) || isLanguage(str))				\
3214 
	str = coerceVector(str, EXPRSXP);				\
3215 
    else if (!isExpression(str))					\
3216 
	str = coerceVector(str, STRSXP);				\
3217 
    PROTECT(str);							\
3218 
    args = CDR(args);							\
3219 
									\
3220 
    if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0)	\
3221 
	errorcall(call, "invalid units");				\
3222 
    args = CDR(args);							\
3223 
									\
3224 
    if (isNull(CAR(args)))						\
3225 
	cex = Rf_gpptr(dd)->cex;					\
3226 
    else if (!R_FINITE(cex = asReal(CAR(args))) || cex <= 0.0)		\
3227 
	errorcall(call, "invalid cex value");				\
3228 
									\
3229 
    n = LENGTH(str);							\
3230 
    PROTECT(ans = allocVector(REALSXP, n));				\
3231 
    cexsave = Rf_gpptr(dd)->cex;					\
3232 
    Rf_gpptr(dd)->cex = cex * Rf_gpptr(dd)->cexbase;			\
3233 
    for (i = 0; i < n; i++)						\
3234 
	if (isExpression(str))						\
3235 
	    REAL(ans)[i] = GExpression ## KIND(VECTOR_ELT(str, i),	\
3236 
					     GMapUnits(units), dd);	\
3237 
	else {								\
3238 
	    ch = STRING_ELT(str, i);					\
3239 
	    REAL(ans)[i] = (ch == NA_STRING) ? 0.0 :			\
3240 
		GStr ## KIND(CHAR(ch), GMapUnits(units), dd);		\
3241 
	}								\
3242 
    Rf_gpptr(dd)->cex = cexsave;					\
3243 
    UNPROTECT(2);							\
3244 
    return ans;								\
258 paul 3245 
}
3246 
 
30691 murdoch 3247 
SEXP do_strheight(SEXP call, SEXP op, SEXP args, SEXP env)
3248 
DO_STR_DIM(Height)
648 ihaka 3249 
 
30691 murdoch 3250 
SEXP do_strwidth (SEXP call, SEXP op, SEXP args, SEXP env)
3251 
DO_STR_DIM(Width)
2 r 3252 
 
30691 murdoch 3253 
#undef DO_STR_DIM
3786 pd 3254 
 
20375 ripley 3255 
 
648 ihaka 3256 
static int *dnd_lptr;
3257 
static int *dnd_rptr;
3258 
static double *dnd_hght;
3259 
static double *dnd_xpos;
3260 
static double dnd_hang;
3261 
static double dnd_offset;
3262 
static SEXP *dnd_llabels;
2 r 3263 
 
648 ihaka 3264 
 
581 paul 3265 
static void drawdend(int node, double *x, double *y, DevDesc *dd)
2 r 3266 
{
30691 murdoch 3267 
/* Recursive function for 'hclust' dendrogram drawing:
3268 
 * Do left + Do right + Do myself
3269 
 * "do" : 1) label leafs (if there are) and __
3270 
 *        2) find coordinates to draw the  | |
3271 
 *        3) return (*x,*y) of "my anchor"
3272 
 */
648 ihaka 3273 
    double xl, xr, yl, yr;
3274 
    double xx[4], yy[4];
3275 
    int k;
30691 murdoch 3276 
 
648 ihaka 3277 
    *y = dnd_hght[node-1];
30691 murdoch 3278 
    /* left part  */
648 ihaka 3279 
    k = dnd_lptr[node-1];
5507 ihaka 3280 
    if (k > 0) drawdend(k, &xl, &yl, dd);
648 ihaka 3281 
    else {
3282 
	xl = dnd_xpos[-k-1];
30691 murdoch 3283 
	yl = (dnd_hang >= 0) ? *y - dnd_hang : 0;
20375 ripley 3284 
	if(dnd_llabels[-k-1] != NA_STRING)
3285 
	    GText(xl, yl-dnd_offset, USER, CHAR(dnd_llabels[-k-1]),
3286 
		  1.0, 0.3, 90.0, dd);
648 ihaka 3287 
    }
30691 murdoch 3288 
    /* right part */
648 ihaka 3289 
    k = dnd_rptr[node-1];
5507 ihaka 3290 
    if (k > 0) drawdend(k, &xr, &yr, dd);
648 ihaka 3291 
    else {
3292 
	xr = dnd_xpos[-k-1];
30691 murdoch 3293 
	yr = (dnd_hang >= 0) ? *y - dnd_hang : 0;
20375 ripley 3294 
	if(dnd_llabels[-k-1] != NA_STRING)
3295 
	    GText(xr, yr-dnd_offset, USER, CHAR(dnd_llabels[-k-1]),
3296 
		  1.0, 0.3, 90.0, dd);
648 ihaka 3297 
    }
3298 
    xx[0] = xl; yy[0] = yl;
3299 
    xx[1] = xl; yy[1] = *y;
3300 
    xx[2] = xr; yy[2] = *y;
3301 
    xx[3] = xr; yy[3] = yr;
3302 
    GPolyline(4, xx, yy, USER, dd);
3303 
    *x = 0.5 * (xl + xr);
3304 
}
2 r 3305 
 
3306 
 
648 ihaka 3307 
SEXP do_dend(SEXP call, SEXP op, SEXP args, SEXP env)
3308 
{
3309 
    double x, y;
30691 murdoch 3310 
    int n;
3311 
 
648 ihaka 3312 
    SEXP originalArgs;
3313 
    DevDesc *dd;
581 paul 3314 
 
648 ihaka 3315 
    dd = CurrentDevice();
3316 
    GCheckState(dd);
3317 
 
3318 
    originalArgs = args;
3319 
    if (length(args) < 6)
5731 ripley 3320 
	errorcall(call, "too few arguments");
648 ihaka 3321 
 
30691 murdoch 3322 
    /* n */
3323 
    n = asInteger(CAR(args));
3324 
    if (n == NA_INTEGER || n < 2)
648 ihaka 3325 
	goto badargs;
3326 
    args = CDR(args);
3327 
 
30691 murdoch 3328 
    /* merge */
3329 
    if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2*n)
648 ihaka 3330 
	goto badargs;
3331 
    dnd_lptr = &(INTEGER(CAR(args))[0]);
30691 murdoch 3332 
    dnd_rptr = &(INTEGER(CAR(args))[n]);
648 ihaka 3333 
    args = CDR(args);
3334 
 
30691 murdoch 3335 
    /* height */
3336 
    if (TYPEOF(CAR(args)) != REALSXP || length(CAR(args)) != n)
648 ihaka 3337 
	goto badargs;
3338 
    dnd_hght = REAL(CAR(args));
3339 
    args = CDR(args);
3340 
 
30691 murdoch 3341 
    /* ord = order(x$order) */
3342 
    if (length(CAR(args)) != n+1)
648 ihaka 3343 
	goto badargs;
30691 murdoch 3344 
    dnd_xpos = REAL(coerceVector(CAR(args),REALSXP));
648 ihaka 3345 
    args = CDR(args);
3346 
 
30691 murdoch 3347 
    /* hang */
648 ihaka 3348 
    dnd_hang = asReal(CAR(args));
5507 ihaka 3349 
    if (!R_FINITE(dnd_hang))
648 ihaka 3350 
	goto badargs;
30691 murdoch 3351 
    dnd_hang = dnd_hang * (dnd_hght[n-1] - dnd_hght[0]);
648 ihaka 3352 
    args = CDR(args);
3353 
 
30691 murdoch 3354 
    /* labels */
3355 
    if (TYPEOF(CAR(args)) != STRSXP || length(CAR(args)) != n+1)
648 ihaka 3356 
	goto badargs;
10172 luke 3357 
    dnd_llabels = STRING_PTR(CAR(args));
648 ihaka 3358 
    args = CDR(args);
3359 
 
3360 
    GSavePars(dd);
19912 duncan 3361 
    ProcessInlinePars(args, dd, call);
17179 murrell 3362 
    Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * Rf_gpptr(dd)->cex;
648 ihaka 3363 
    dnd_offset = GConvertYUnits(GStrWidth("m", INCHES, dd), INCHES, USER, dd);
3364 
 
5055 pd 3365 
    /* override par("xpd") and force clipping to figure region */
3366 
    /* NOTE: don't override to _reduce_ clipping region */
17179 murrell 3367 
    if (Rf_gpptr(dd)->xpd < 1)
3368 
	Rf_gpptr(dd)->xpd = 1;
5055 pd 3369 
 
3367 ihaka 3370 
    GMode(1, dd);
30691 murdoch 3371 
    drawdend(n, &x, &y, dd);
3367 ihaka 3372 
    GMode(0, dd);
648 ihaka 3373 
    GRestorePars(dd);
3374 
    /* NOTE: only record operation if no "error"  */
11067 maechler 3375 
    if (GRecording(call))
648 ihaka 3376 
	recordGraphicOperation(op, originalArgs, dd);
3377 
    return R_NilValue;
3378 
 
3379 
  badargs:
5731 ripley 3380 
    error("invalid dendrogram input");
987 maechler 3381 
    return R_NilValue;/* never used; to keep -Wall happy */
2 r 3382 
}
3383 
 
648 ihaka 3384 
SEXP do_dendwindow(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 3385 
{
987 maechler 3386 
    int i, imax, n;
26479 maechler 3387 
    double pin, *ll, tmp, yval, *y, ymin, ymax, yrange, m;
20375 ripley 3388 
    SEXP originalArgs, merge, height, llabels, str;
648 ihaka 3389 
    char *vmax;
3390 
    DevDesc *dd;
26479 maechler 3391 
 
648 ihaka 3392 
    dd = CurrentDevice();
3393 
    GCheckState(dd);
3394 
    originalArgs = args;
30691 murdoch 3395 
    if (length(args) < 5)
6191 maechler 3396 
	errorcall(call, "too few arguments");
648 ihaka 3397 
    n = asInteger(CAR(args));
5507 ihaka 3398 
    if (n == NA_INTEGER || n < 2)
648 ihaka 3399 
	goto badargs;
3400 
    args = CDR(args);
5507 ihaka 3401 
    if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2 * n)
648 ihaka 3402 
	goto badargs;
3403 
    merge = CAR(args);
30691 murdoch 3404 
 
648 ihaka 3405 
    args = CDR(args);
5507 ihaka 3406 
    if (TYPEOF(CAR(args)) != REALSXP || length(CAR(args)) != n)
648 ihaka 3407 
	goto badargs;
3408 
    height = CAR(args);
30691 murdoch 3409 
 
648 ihaka 3410 
    args = CDR(args);
3411 
    dnd_hang = asReal(CAR(args));
5507 ihaka 3412 
    if (!R_FINITE(dnd_hang))
648 ihaka 3413 
	goto badargs;
30691 murdoch 3414 
 
648 ihaka 3415 
    args = CDR(args);
5507 ihaka 3416 
    if (TYPEOF(CAR(args)) != STRSXP || length(CAR(args)) != n + 1)
3417 
	goto badargs;
30691 murdoch 3418 
    llabels = CAR(args);
2 r 3419 
 
648 ihaka 3420 
    args = CDR(args);
3421 
    GSavePars(dd);
19912 duncan 3422 
    ProcessInlinePars(args, dd, call);
17179 murrell 3423 
    Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * Rf_gpptr(dd)->cex;
648 ihaka 3424 
    dnd_offset = GStrWidth("m", INCHES, dd);
3425 
    vmax = vmaxget();
26479 maechler 3426 
    y =  (double*)R_alloc(n, sizeof(double));
3427 
    ll = (double*)R_alloc(n, sizeof(double));
648 ihaka 3428 
    dnd_lptr = &(INTEGER(merge)[0]);
3429 
    dnd_rptr = &(INTEGER(merge)[n]);
26479 maechler 3430 
    ymax = ymin = REAL(height)[0];
3431 
    for (i = 1; i < n; i++) {
3432 
	m = REAL(height)[i];
3433 
	if (m > ymax)
3434 
	    ymax = m;
3435 
	else if (m < ymin)
3436 
	    ymin = m;
3437 
    }
17179 murrell 3438 
    pin = Rf_gpptr(dd)->pin[1];
20377 ripley 3439 
    for (i = 0; i < n; i++) {
20375 ripley 3440 
	str = STRING_ELT(llabels, i);
3441 
	ll[i] = (str == NA_STRING) ? 0.0 :
3442 
	    GStrWidth(CHAR(str), INCHES, dd) + dnd_offset;
20377 ripley 3443 
    }
30691 murdoch 3444 
 
3445 
    imax = -1; yval = -DBL_MAX;
5507 ihaka 3446 
    if (dnd_hang >= 0) {
648 ihaka 3447 
	ymin = ymax - (1 + dnd_hang) * (ymax - ymin);
3448 
	yrange = ymax - ymin;
3449 
	/* determine leaf heights */
5507 ihaka 3450 
	for (i = 0; i < n; i++) {
648 ihaka 3451 
	    if (dnd_lptr[i] < 0)
3452 
		y[-dnd_lptr[i] - 1] = REAL(height)[i];
3453 
	    if (dnd_rptr[i] < 0)
3454 
		y[-dnd_rptr[i] - 1] = REAL(height)[i];
3455 
	}
3456 
	/* determine the most extreme label depth */
3457 
	/* assuming that we are using the full plot */
3458 
	/* window for the tree itself */
5507 ihaka 3459 
	for (i = 0; i < n; i++) {
648 ihaka 3460 
	    tmp = ((ymax - y[i]) / yrange) * pin + ll[i];
3461 
	    if (tmp > yval) {
3462 
		yval = tmp;
3463 
		imax = i;
3464 
	    }
3465 
	}
3466 
    }
3467 
    else {
3468 
	yrange = ymax;
5507 ihaka 3469 
	for (i = 0; i < n; i++) {
648 ihaka 3470 
	    tmp = pin + ll[i];
3471 
	    if (tmp > yval) {
3472 
		yval = tmp;
3473 
		imax = i;
3474 
	    }
3475 
	}
3476 
    }
3477 
    /* now determine how much to scale */
30691 murdoch 3478 
    ymin = ymax - (pin/(pin - ll[imax])) * yrange;
3479 
    GScale(1.0, n+1.0, 1 /* x */, dd);
3480 
    GScale(ymin, ymax, 2 /* y */, dd);
648 ihaka 3481 
    GMapWin2Fig(dd);
3482 
    GRestorePars(dd);
3483 
    /* NOTE: only record operation if no "error"  */
11067 maechler 3484 
    if (GRecording(call))
648 ihaka 3485 
	recordGraphicOperation(op, originalArgs, dd);
3486 
    vmaxset(vmax);
3487 
    return R_NilValue;
3488 
  badargs:
5731 ripley 3489 
    error("invalid dendrogram input");
987 maechler 3490 
    return R_NilValue;/* never used; to keep -Wall happy */
648 ihaka 3491 
}
2 r 3492 
 
648 ihaka 3493 
 
581 paul 3494 
SEXP do_erase(SEXP call, SEXP op, SEXP args, SEXP env)
3495 
{
648 ihaka 3496 
    SEXP col;
3497 
    int ncol;
3498 
    DevDesc *dd = CurrentDevice();
3499 
    checkArity(op, args);
5507 ihaka 3500 
    PROTECT(col = FixupCol(CAR(args), NA_INTEGER));
648 ihaka 3501 
    ncol = LENGTH(col);
3502 
    GSavePars(dd);
3367 ihaka 3503 
    GMode(1, dd);
648 ihaka 3504 
    GRect(0.0, 0.0, 1.0, 1.0, NDC, INTEGER(col)[0], NA_INTEGER, dd);
3367 ihaka 3505 
    GMode(0, dd);
648 ihaka 3506 
    GRestorePars(dd);
3507 
    UNPROTECT(1);
3508 
    return R_NilValue;
2 r 3509 
}
3510 
 
648 ihaka 3511 
 
17127 ripley 3512 
SEXP do_getSnapshot(SEXP call, SEXP op, SEXP args, SEXP env)
3513 
{
3514 
    DevDesc *dd = CurrentDevice();
3515 
 
3516 
    checkArity(op, args);
3517 
    if (dd->newDevStruct) {
3518 
	return GEcreateSnapshot((GEDevDesc*) dd);
3519 
    } else {
3520 
	errorcall(call, "can't take snapshot of old-style device");
3521 
	return R_NilValue;
3522 
    }
3523 
}
3524 
 
3525 
SEXP do_playSnapshot(SEXP call, SEXP op, SEXP args, SEXP env)
3526 
{
3527 
    DevDesc *dd = CurrentDevice();
3528 
 
3529 
    checkArity(op, args);
3530 
    if (dd->newDevStruct)
3531 
	GEplaySnapshot(CAR(args), (GEDevDesc*) dd);
3532 
    else
3533 
	errorcall(call, "can't play snapshot on old-style device");
3534 
    return R_NilValue;
3535 
}
3536 
 
17113 murrell 3537 
/* I don't think this gets called in any base R code
3538 
 */
581 paul 3539 
SEXP do_replay(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 3540 
{
17113 murrell 3541 
    if (!NoDevices()) {
3542 
	GEDevDesc *dd = GEcurrentDevice();
3543 
	checkArity(op, args);
17179 murrell 3544 
	/*     Rf_dpptr(dd)->resize(); */
17113 murrell 3545 
	GEplayDisplayList(dd);
3546 
    }
648 ihaka 3547 
    return R_NilValue;
2 r 3548 
}
9157 ripley 3549 
 
3550 
SEXP do_playDL(SEXP call, SEXP op, SEXP args, SEXP env)
3551 
{
3552 
    DevDesc *dd = CurrentDevice();
3553 
    SEXP theList;
3554 
    int ask;
3555 
 
3556 
    checkArity(op, args);
3557 
    if(!isList(theList = CAR(args)))
3558 
       errorcall(call, "invalid argument");
16881 murrell 3559 
    if (dd->newDevStruct)
3560 
	((GEDevDesc*) dd)->dev->displayList = theList;
3561 
    else
3562 
	dd->displayList = theList;
9157 ripley 3563 
    if (theList != R_NilValue) {
17179 murrell 3564 
	ask = Rf_gpptr(dd)->ask;
3565 
	Rf_gpptr(dd)->ask = 1;
9157 ripley 3566 
	GReset(dd);
3567 
	while (theList != R_NilValue) {
3568 
	    SEXP theOperation = CAR(theList);
11067 maechler 3569 
	    SEXP l_op = CAR(theOperation);
3570 
	    SEXP l_args = CDR(theOperation);
3571 
	    PRIMFUN(l_op) (R_NilValue, l_op, l_args, R_NilValue);
17179 murrell 3572 
	    if (!Rf_gpptr(dd)->valid) break;
9157 ripley 3573 
	    theList = CDR(theList);
3574 
	}
17179 murrell 3575 
	Rf_gpptr(dd)->ask = ask;
9278 maechler 3576 
    }
9157 ripley 3577 
    return R_NilValue;
3578 
}
3579 
 
3580 
SEXP do_setGPar(SEXP call, SEXP op, SEXP args, SEXP env)
3581 
{
3582 
    DevDesc *dd = CurrentDevice();
3583 
    int lGPar = 1 + sizeof(GPar) / sizeof(int);
3584 
    SEXP GP;
9278 maechler 3585 
 
9157 ripley 3586 
    checkArity(op, args);
3587 
    GP = CAR(args);
3588 
    if (!isInteger(GP) || length(GP) != lGPar)
3589 
	errorcall(call, "invalid graphics parameter list");
17179 murrell 3590 
    copyGPar((GPar *) INTEGER(GP), Rf_dpSavedptr(dd)); /* &dd->Rf_dpSaved); */
9157 ripley 3591 
    return R_NilValue;
3592 
}
9240 ihaka 3593 
 
16797 maechler 3594 
/* symbols(..) in ../library/base/R/symbols.R  : */
3595 
 
16808 maechler 3596 
/* utility just computing range() */
3597 
static Rboolean SymbolRange(double *x, int n, double *xmax, double *xmin)
9240 ihaka 3598 
{
3599 
    int i;
3600 
    *xmax = -DBL_MAX;
3601 
    *xmin =  DBL_MAX;
3602 
    for(i = 0; i < n; i++)
16482 maechler 3603 
	if (R_FINITE(x[i])) {
9240 ihaka 3604 
	    if (*xmax < x[i]) *xmax = x[i];
3605 
	    if (*xmin > x[i]) *xmin = x[i];
16482 maechler 3606 
	}
16808 maechler 3607 
    return(*xmax >= *xmin && *xmin >= 0);
9240 ihaka 3608 
}
3609 
 
9248 ripley 3610 
static void CheckSymbolPar(SEXP call, SEXP p, int *nr, int *nc)
9240 ihaka 3611 
{
3612 
    SEXP dim = getAttrib(p, R_DimSymbol);
3613 
    switch(length(dim)) {
3614 
    case 0:
3615 
	*nr = LENGTH(p);
3616 
	*nc = 1;
3617 
	break;
3618 
    case 1:
3619 
	*nr = INTEGER(dim)[0];
3620 
	*nc = 1;
3621 
	break;
3622 
    case 2:
3623 
	*nr = INTEGER(dim)[0];
3624 
	*nc = INTEGER(dim)[1];
3625 
	break;
3626 
    default:
3627 
	*nr = 0;
3628 
	*nc = 0;
3629 
    }
3630 
    if (*nr == 0 || *nc == 0)
3631 
	errorcall(call, "invalid symbol parameter vector");
3632 
}
3633 
 
16797 maechler 3634 
/* Internal  symbols(x, y, type, data, inches, bg, fg, ...) */
9250 ihaka 3635 
SEXP do_symbols(SEXP call, SEXP op, SEXP args, SEXP env)
9240 ihaka 3636 
{
3637 
    SEXP x, y, p, fg, bg;
16808 maechler 3638 
    int i, j, nr, nc, nbg, nfg, type;
9240 ihaka 3639 
    double pmax, pmin, inches, rx, ry;
3640 
    double xx, yy, p0, p1, p2, p3, p4;
3641 
    double *pp, *xp, *yp;
3642 
    char *vmax;
3643 
 
3644 
    SEXP originalArgs = args;
3645 
    DevDesc *dd = CurrentDevice();
3646 
    GCheckState(dd);
3647 
 
3648 
    if (length(args) < 7)
3649 
	errorcall(call, "insufficient arguments");
3650 
 
9250 ihaka 3651 
    PROTECT(x = coerceVector(CAR(args), REALSXP)); args = CDR(args);
3652 
    PROTECT(y = coerceVector(CAR(args), REALSXP)); args = CDR(args);
9240 ihaka 3653 
    if (!isNumeric(x) || !isNumeric(y) || length(x) <= 0 || LENGTH(x) <= 0)
16482 maechler 3654 
	errorcall(call, "invalid symbol coordinates");
9240 ihaka 3655 
 
3656 
    type = asInteger(CAR(args)); args = CDR(args);
3657 
 
16797 maechler 3658 
    /* data: */
9240 ihaka 3659 
    p = PROTECT(coerceVector(CAR(args), REALSXP)); args = CDR(args);
3660 
    CheckSymbolPar(call, p, &nr, &nc);
3661 
    if (LENGTH(x) != nr || LENGTH(y) != nr)
3662 
	errorcall(call, "x/y/parameter length mismatch");
3663 
 
3664 
    inches = asReal(CAR(args)); args = CDR(args);
3665 
    if (!R_FINITE(inches) || inches < 0)
3666 
	inches = 0;
3667 
 
3668 
    PROTECT(bg = FixupCol(CAR(args), NA_INTEGER)); args = CDR(args);
3669 
    nbg = LENGTH(bg);
3670 
 
3671 
    PROTECT(fg = FixupCol(CAR(args), NA_INTEGER)); args = CDR(args);
3672 
    nfg = LENGTH(fg);
3673 
 
3674 
    GSavePars(dd);
19912 duncan 3675 
    ProcessInlinePars(args, dd, call);
9240 ihaka 3676 
 
3677 
    GMode(1, dd);
3678 
    switch (type) {
3679 
    case 1: /* circles */
3680 
	if (nc != 1)
16808 maechler 3681 
	    errorcall(call, "invalid circles data");
3682 
	if (!SymbolRange(REAL(p), nr, &pmax, &pmin))
9240 ihaka 3683 
	    errorcall(call, "invalid symbol parameter");
3684 
	for (i = 0; i < nr; i++) {
16808 maechler 3685 
	    if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
3686 
		R_FINITE(REAL(p)[i])) {
9240 ihaka 3687 
		rx = REAL(p)[i];
3688 
		if (inches > 0)
16912 maechler 3689 
		    rx *= inches / pmax;/* <-- no GConvert ?? */
16808 maechler 3690 
		else/* FIXME : INCHES in the following ??? */
9240 ihaka 3691 
		    rx = GConvertXUnits(rx, USER, INCHES, dd);
3692 
		GCircle(REAL(x)[i], REAL(y)[i],	USER, rx,
3693 
			INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg],	dd);
3694 
	    }
3695 
	}
3696 
	break;
3697 
    case 2: /* squares */
16808 maechler 3698 
	if(nc != 1)
3699 
	    errorcall(call, "invalid squares data");
3700 
	if(!SymbolRange(REAL(p), nr, &pmax, &pmin))
9240 ihaka 3701 
	    errorcall(call, "invalid symbol parameter");
3702 
	for (i = 0; i < nr; i++) {
16808 maechler 3703 
	    if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
3704 
		R_FINITE(REAL(p)[i])) {
9240 ihaka 3705 
		p0 = REAL(p)[i];
3706 
		xx = REAL(x)[i];
3707 
		yy = REAL(y)[i];
16808 maechler 3708 
		GConvert(&xx, &yy, USER, DEVICE, dd);
9240 ihaka 3709 
		if (inches > 0) {
3710 
		    p0 = p0 / pmax * inches;
16808 maechler 3711 
		    rx = GConvertXUnits(0.5 * p0, INCHES, DEVICE, dd);
3712 
		    ry = GConvertYUnits(0.5 * p0, INCHES, DEVICE, dd);
9240 ihaka 3713 
		}
3714 
		else {
16808 maechler 3715 
		    rx = GConvertXUnits(0.5 * p0, USER, DEVICE, dd);
3716 
		    ry = GConvertYUnits(0.5 * p0, USER, DEVICE, dd);
9240 ihaka 3717 
		}
16808 maechler 3718 
		GRect(xx - rx, yy - rx, xx + rx, yy + rx, DEVICE,
9240 ihaka 3719 
		      INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
3720 
	    }
3721 
	}
3722 
	break;
3723 
    case 3: /* rectangles */
3724 
	if (nc != 2)
16808 maechler 3725 
	    errorcall(call, "invalid rectangles data (need 2 columns)");
3726 
	if (!SymbolRange(REAL(p), 2 * nr, &pmax, &pmin))
9240 ihaka 3727 
	    errorcall(call, "invalid symbol parameter");
3728 
	for (i = 0; i < nr; i++) {
16808 maechler 3729 
	    if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
3730 
		R_FINITE(REAL(p)[i]) && R_FINITE(REAL(p)[i+nr])) {
9240 ihaka 3731 
		xx = REAL(x)[i];
3732 
		yy = REAL(y)[i];
3733 
		GConvert(&xx, &yy, USER, DEVICE, dd);
3734 
		p0 = REAL(p)[i];
3735 
		p1 = REAL(p)[i+nr];
3736 
		if (inches > 0) {
16808 maechler 3737 
		    p0 *= inches / pmax;
3738 
		    p1 *= inches / pmax;
9240 ihaka 3739 
		    rx = GConvertXUnits(0.5 * p0, INCHES, DEVICE, dd);
3740 
		    ry = GConvertYUnits(0.5 * p1, INCHES, DEVICE, dd);
3741 
		}
3742 
		else {
3743 
		    rx = GConvertXUnits(0.5 * p0, USER, DEVICE, dd);
3744 
		    ry = GConvertYUnits(0.5 * p1, USER, DEVICE, dd);
3745 
		}
3746 
		GRect(xx - rx, yy - ry, xx + rx, yy + ry, DEVICE,
3747 
		      INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
3748 
 
3749 
	    }
3750 
	}
3751 
	break;
3752 
    case 4: /* stars */
3753 
	if (nc < 3)
3754 
	    errorcall(call, "invalid stars data");
16912 maechler 3755 
	if (!SymbolRange(REAL(p), nc * nr, &pmax, &pmin))
9240 ihaka 3756 
	    errorcall(call, "invalid symbol parameter");
3757 
	vmax = vmaxget();
3758 
	pp = (double*)R_alloc(nc, sizeof(double));
3759 
	xp = (double*)R_alloc(nc, sizeof(double));
3760 
	yp = (double*)R_alloc(nc, sizeof(double));
3761 
	p1 = 2.0 * M_PI / nc;
3762 
	for (i = 0; i < nr; i++) {
3763 
	    xx = REAL(x)[i];
3764 
	    yy = REAL(y)[i];
3765 
	    if (R_FINITE(xx) && R_FINITE(yy)) {
3766 
		GConvert(&xx, &yy, USER, NDC, dd);
3767 
		if (inches > 0) {
3768 
		    for(j = 0; j < nc; j++) {
3769 
			p0 = REAL(p)[i + j * nr];
3770 
			if (!R_FINITE(p0)) p0 = 0;
3771 
			pp[j] = (p0 / pmax) * inches;
3772 
		    }
3773 
		}
3774 
		else {
3775 
		    for(j = 0; j < nc; j++) {
3776 
			p0 = REAL(p)[i + j * nr];
3777 
			if (!R_FINITE(p0)) p0 = 0;
16482 maechler 3778 
			pp[j] =	 GConvertXUnits(p0, USER, INCHES, dd);
9240 ihaka 3779 
		    }
3780 
		}
3781 
		for(j = 0; j < nc; j++) {
3782 
		    xp[j] = GConvertXUnits(pp[j] * cos(j * p1),
3783 
					   INCHES, NDC, dd) + xx;
3784 
		    yp[j] = GConvertYUnits(pp[j] * sin(j * p1),
3785 
					   INCHES, NDC, dd) + yy;
3786 
		}
3787 
		GPolygon(nc, xp, yp, NDC,
3788 
			 INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
3789 
	    }
3790 
	}
3791 
	vmaxset(vmax);
3792 
	break;
3793 
    case 5: /* thermometers */
3794 
	if (nc != 3 && nc != 4)
16808 maechler 3795 
	    errorcall(call, "invalid thermometers data (need 3 or 4 columns)");
22974 ripley 3796 
	SymbolRange(REAL(p)+2*nr/* <-- pointer arith*/, nr, &pmax, &pmin);
16912 maechler 3797 
	if (pmax < pmin)
3798 
	    errorcall(call, "invalid thermometers[,%s]",(nc == 4)? "3:4" : "3");
3799 
	if (pmin < 0. || pmax > 1.) /* S-PLUS has an error here */
3800 
	    warningcall(call,"thermometers[,%s] not in [0,1] -- may look funny",
3801 
			(nc == 4)? "3:4" : "3");
16808 maechler 3802 
	if (!SymbolRange(REAL(p), 2 * nr, &pmax, &pmin))
16912 maechler 3803 
	    errorcall(call, "invalid thermometers[,1:2]");
9240 ihaka 3804 
	for (i = 0; i < nr; i++) {
3805 
	    xx = REAL(x)[i];
3806 
	    yy = REAL(y)[i];
3807 
	    if (R_FINITE(xx) && R_FINITE(yy)) {
3808 
		p0 = REAL(p)[i];
3809 
		p1 = REAL(p)[i + nr];
3810 
		p2 = REAL(p)[i + 2 * nr];
16808 maechler 3811 
		p3 = (nc == 4)? REAL(p)[i + 3 * nr] : 0.;
3812 
		if (R_FINITE(p0) && R_FINITE(p1) &&
3813 
		    R_FINITE(p2) && R_FINITE(p3)) {
3814 
		    if (p2 < 0) p2 = 0; else if (p2 > 1) p2 = 1;
3815 
		    if (p3 < 0) p3 = 0; else if (p3 > 1) p3 = 1;
9240 ihaka 3816 
		    GConvert(&xx, &yy, USER, NDC, dd);
3817 
		    if (inches > 0) {
16808 maechler 3818 
			p0 *= inches / pmax;
3819 
			p1 *= inches / pmax;
9240 ihaka 3820 
			rx = GConvertXUnits(0.5 * p0, INCHES, NDC, dd);
3821 
			ry = GConvertYUnits(0.5 * p1, INCHES, NDC, dd);
3822 
		    }
3823 
		    else {
3824 
			rx = GConvertXUnits(0.5 * p0, USER, NDC, dd);
3825 
			ry = GConvertYUnits(0.5 * p1, USER, NDC, dd);
9278 maechler 3826 
		    }
9240 ihaka 3827 
		    GRect(xx - rx, yy - ry, xx + rx, yy + ry, NDC,
3828 
			  INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
3829 
		    GRect(xx - rx,  yy - (1 - 2 * p2) * ry,
3830 
			  xx + rx,  yy - (1 - 2 * p3) * ry,
3831 
			  NDC,
3832 
			  INTEGER(fg)[i%nfg], INTEGER(fg)[i%nfg], dd);
3833 
		    GLine(xx - rx, yy, xx - 1.5 * rx, yy, NDC, dd);
3834 
		    GLine(xx + rx, yy, xx + 1.5 * rx, yy, NDC, dd);
3835 
 
3836 
		}
3837 
	    }
3838 
	}
3839 
	break;
16912 maechler 3840 
    case 6: /* boxplots (wid, hei, loWhsk, upWhsk, medProp) */
9240 ihaka 3841 
	if (nc != 5)
16808 maechler 3842 
	    errorcall(call, "invalid boxplots data (need 5 columns)");
9245 ihaka 3843 
	pmax = -DBL_MAX;
16482 maechler 3844 
	pmin =	DBL_MAX;
9245 ihaka 3845 
	for(i = 0; i < nr; i++) {
16912 maechler 3846 
	    p4 = REAL(p)[i + 4 * nr];	/* median proport. in [0,1] */
3847 
	    if (pmax < p4) pmax = p4;
3848 
	    if (pmin > p4) pmin = p4;
9245 ihaka 3849 
	}
16912 maechler 3850 
	if (pmin < 0. || pmax > 1.) /* S-PLUS has an error here */
3851 
	    warningcall(call, "boxplots[,5] outside [0,1] -- may look funny");
3852 
	if (!SymbolRange(REAL(p), 4 * nr, &pmax, &pmin))
3853 
	    errorcall(call, "invalid boxplots[, 1:4]");
9240 ihaka 3854 
	for (i = 0; i < nr; i++) {
3855 
	    xx = REAL(x)[i];
3856 
	    yy = REAL(y)[i];
3857 
	    if (R_FINITE(xx) && R_FINITE(yy)) {
16912 maechler 3858 
		p0 = REAL(p)[i];	/* width */
21044 maechler 3859 
		p1 = REAL(p)[i + nr];	/* height */
16912 maechler 3860 
		p2 = REAL(p)[i + 2 * nr];/* lower whisker */
3861 
		p3 = REAL(p)[i + 3 * nr];/* upper whisker */
3862 
		p4 = REAL(p)[i + 4 * nr];/* median proport. in [0,1] */
16808 maechler 3863 
		if (R_FINITE(p0) && R_FINITE(p1) &&
3864 
		    R_FINITE(p2) && R_FINITE(p3) && R_FINITE(p4)) {
9240 ihaka 3865 
		    GConvert(&xx, &yy, USER, NDC, dd);
3866 
		    if (inches > 0) {
16808 maechler 3867 
			p0 *= inches / pmax;
3868 
			p1 *= inches / pmax;
3869 
			p2 *= inches / pmax;
3870 
			p3 *= inches / pmax;
9240 ihaka 3871 
			p0 = GConvertXUnits(p0, INCHES, NDC, dd);
3872 
			p1 = GConvertYUnits(p1, INCHES, NDC, dd);
3873 
			p2 = GConvertYUnits(p2, INCHES, NDC, dd);
3874 
			p3 = GConvertYUnits(p3, INCHES, NDC, dd);
3875 
		    }
3876 
		    else {
3877 
			p0 = GConvertXUnits(p0, USER, NDC, dd);
3878 
			p1 = GConvertYUnits(p1, USER, NDC, dd);
3879 
			p2 = GConvertYUnits(p2, USER, NDC, dd);
3880 
			p3 = GConvertYUnits(p3, USER, NDC, dd);
3881 
		    }
3882 
		    rx = 0.5 * p0;
3883 
		    ry = 0.5 * p1;
3884 
		    p4 = (1 - p4) * (yy - ry) + p4 * (yy + ry);
3885 
		    /* Box */
3886 
		    GRect(xx - rx, yy - ry, xx + rx, yy + ry, NDC,
3887 
			  INTEGER(bg)[i%nbg], INTEGER(fg)[i%nfg], dd);
3888 
		    /* Median */
3889 
		    GLine(xx - rx, p4, xx + rx, p4, NDC, dd);
3890 
		    /* Lower Whisker */
3891 
		    GLine(xx, yy - ry, xx, yy - ry - p2, NDC, dd);
3892 
		    /* Upper Whisker */
3893 
		    GLine(xx, yy + ry, xx, yy + ry + p3, NDC, dd);
3894 
		}
3895 
	    }
3896 
	}
3897 
	break;
3898 
    default:
3899 
	errorcall(call, "invalid symbol type");
3900 
    }
3901 
    GMode(0, dd);
3902 
    GRestorePars(dd);
11067 maechler 3903 
    if (GRecording(call))
9240 ihaka 3904 
	recordGraphicOperation(op, originalArgs, dd);
3905 
    UNPROTECT(5);
9250 ihaka 3906 
    return R_NilValue;
9240 ihaka 3907 
}