The R Project SVN R

Rev

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