The R Project SVN R

Rev

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

Rev 26007 Rev 26479
Line 1... Line 1...
1
/*
1
/*
2
 *  R : A Computer Language for Statistical Data Analysis
2
 *  R : A Computer Language for Statistical Data Analysis
3
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
3
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
4
 *  Copyright (C) 1997--2003  Robert Gentleman, Ross Ihaka and the
4
 *  Copyright (C) 1997--2001  Robert Gentleman, Ross Ihaka and the
5
 *			      R Development Core Team
5
 *			      R Development Core Team
-
 
6
 *  Copyright (C) 2002--2003  The R Foundation
6
 *
7
 *
7
 *  This program is free software; you can redistribute it and/or modify
8
 *  This program is free software; you can redistribute it and/or modify
8
 *  it under the terms of the GNU General Public License as published by
9
 *  it under the terms of the GNU General Public License as published by
9
 *  the Free Software Foundation; either version 2 of the License, or
10
 *  the Free Software Foundation; either version 2 of the License, or
10
 *  (at your option) any later version.
11
 *  (at your option) any later version.
Line 12... Line 13...
12
 *  This program is distributed in the hope that it will be useful,
13
 *  This program is distributed in the hope that it will be useful,
13
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
 *  GNU General Public License for more details.
16
 *  GNU General Public License for more details.
16
 *
17
 *
17
 *  You should have received a copy of the GNU General Public License
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
18
 *  along with this program; if not, write to the Free Software
20
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
19
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
21
 *  Suite 330, Boston, MA  02111-1307  USA.
20
 */
22
 */
21
 
23
 
22
#ifdef HAVE_CONFIG_H
24
#ifdef HAVE_CONFIG_H
23
#include <config.h>
25
#include <config.h>
24
#endif
26
#endif
Line 50... Line 52...
50
 
52
 
51
 
53
 
52
SEXP do_devcontrol(SEXP call, SEXP op, SEXP args, SEXP env)
54
SEXP do_devcontrol(SEXP call, SEXP op, SEXP args, SEXP env)
53
{
55
{
54
    int listFlag;
56
    int listFlag;
55
    
57
 
56
    checkArity(op, args);
58
    checkArity(op, args);
57
    listFlag = asLogical(CAR(args));
59
    listFlag = asLogical(CAR(args));
58
    if(listFlag == NA_LOGICAL) errorcall(call, "invalid argument");
60
    if(listFlag == NA_LOGICAL) errorcall(call, "invalid argument");
59
    if(listFlag)
61
    if(listFlag)
60
	enableDisplayList(CurrentDevice());
62
	enableDisplayList(CurrentDevice());
Line 393... Line 395...
393
		    PROTECT(txt = coerceVector(txt, EXPRSXP));
395
		    PROTECT(txt = coerceVector(txt, EXPRSXP));
394
	       }
396
	       }
395
	       else if (!isExpression(txt)) {
397
	       else if (!isExpression(txt)) {
396
		    UNPROTECT(1);
398
		    UNPROTECT(1);
397
		    PROTECT(txt = coerceVector(txt, STRSXP));
399
		    PROTECT(txt = coerceVector(txt, STRSXP));
398
	       } 
400
	       }
399
	    } else {
401
	    } else {
400
	       n = length(nms);
402
	       n = length(nms);
401
	       for (i = 0; i < n; i++) {
403
	       for (i = 0; i < n; i++) {
402
		if (!strcmp(CHAR(STRING_ELT(nms, i)), "cex")) {
404
		if (!strcmp(CHAR(STRING_ELT(nms, i)), "cex")) {
403
		    cex = asReal(VECTOR_ELT(spec, i));
405
		    cex = asReal(VECTOR_ELT(spec, i));
Line 1049... Line 1051...
1049
	    else
1051
	    else
1050
		axis_base = GConvertY(0.0, outer, NFC, dd)
1052
		axis_base = GConvertY(0.0, outer, NFC, dd)
1051
		    - GConvertYUnits(line, LINES, NFC, dd);
1053
		    - GConvertYUnits(line, LINES, NFC, dd);
1052
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1054
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1053
		double len, xu, yu;
1055
		double len, xu, yu;
1054
		if(Rf_gpptr(dd)->tck > 0.5) 
1056
		if(Rf_gpptr(dd)->tck > 0.5)
1055
		    len = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1057
		    len = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1056
		else {
1058
		else {
1057
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1059
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1058
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1060
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1059
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1061
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
Line 1071... Line 1073...
1071
	    else
1073
	    else
1072
		axis_base =  GConvertY(1.0, outer, NFC, dd)
1074
		axis_base =  GConvertY(1.0, outer, NFC, dd)
1073
		    + GConvertYUnits(line, LINES, NFC, dd);
1075
		    + GConvertYUnits(line, LINES, NFC, dd);
1074
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1076
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1075
		double len, xu, yu;
1077
		double len, xu, yu;
1076
		if(Rf_gpptr(dd)->tck > 0.5) 
1078
		if(Rf_gpptr(dd)->tck > 0.5)
1077
		    len = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1079
		    len = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1078
		else {
1080
		else {
1079
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1081
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1080
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1082
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1081
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1083
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1082
		    len = GConvertYUnits(xu, INCHES, NFC, dd);
1084
		    len = GConvertYUnits(xu, INCHES, NFC, dd);
1083
		}
1085
		}
1084
		axis_tick = axis_base - len;
1086
		axis_tick = axis_base - len;
1085
	    } else
1087
	    } else
1086
		axis_tick = axis_base - 
1088
		axis_tick = axis_base -
1087
		    GConvertYUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
1089
		    GConvertYUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
1088
	}
1090
	}
1089
	if (doticks) {
1091
	if (doticks) {
1090
	    Rf_gpptr(dd)->col = col;/*was fg */
1092
	    Rf_gpptr(dd)->col = col;/*was fg */
1091
	    GLine(axis_low, axis_base, axis_high, axis_base, NFC, dd);
1093
	    GLine(axis_low, axis_base, axis_high, axis_base, NFC, dd);
Line 1174... Line 1176...
1174
	    else
1176
	    else
1175
		axis_base =  GConvertX(0.0, outer, NFC, dd)
1177
		axis_base =  GConvertX(0.0, outer, NFC, dd)
1176
		    - GConvertXUnits(line, LINES, NFC, dd);
1178
		    - GConvertXUnits(line, LINES, NFC, dd);
1177
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1179
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1178
		double len, xu, yu;
1180
		double len, xu, yu;
1179
		if(Rf_gpptr(dd)->tck > 0.5) 
1181
		if(Rf_gpptr(dd)->tck > 0.5)
1180
		    len = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1182
		    len = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1181
		else {
1183
		else {
1182
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1184
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1183
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1185
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1184
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1186
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1185
		    len = GConvertXUnits(xu, INCHES, NFC, dd);
1187
		    len = GConvertXUnits(xu, INCHES, NFC, dd);
1186
		}
1188
		}
1187
		axis_tick = axis_base + len;
1189
		axis_tick = axis_base + len;
1188
	    } else
1190
	    } else
1189
		axis_tick = axis_base + 
1191
		axis_tick = axis_base +
1190
		    GConvertXUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
1192
		    GConvertXUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
1191
	}
1193
	}
1192
	else {
1194
	else {
1193
	    if (R_FINITE(pos))
1195
	    if (R_FINITE(pos))
1194
		axis_base = GConvertX(pos, USER, NFC, dd);
1196
		axis_base = GConvertX(pos, USER, NFC, dd);
1195
	    else
1197
	    else
1196
		axis_base =  GConvertX(1.0, outer, NFC, dd)
1198
		axis_base =  GConvertX(1.0, outer, NFC, dd)
1197
		    + GConvertXUnits(line, LINES, NFC, dd);
1199
		    + GConvertXUnits(line, LINES, NFC, dd);
1198
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1200
	    if (R_FINITE(Rf_gpptr(dd)->tck)) {
1199
		double len, xu, yu;
1201
		double len, xu, yu;
1200
		if(Rf_gpptr(dd)->tck > 0.5) 
1202
		if(Rf_gpptr(dd)->tck > 0.5)
1201
		    len = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1203
		    len = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, NFC, dd);
1202
		else {
1204
		else {
1203
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1205
		    xu = GConvertXUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1204
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1206
		    yu = GConvertYUnits(Rf_gpptr(dd)->tck, NPC, INCHES, dd);
1205
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1207
		    xu = (fabs(xu) < fabs(yu)) ? xu : yu;
1206
		    len = GConvertXUnits(xu, INCHES, NFC, dd);
1208
		    len = GConvertXUnits(xu, INCHES, NFC, dd);
1207
		}
1209
		}
1208
		axis_tick = axis_base - len;
1210
		axis_tick = axis_base - len;
1209
	    } else
1211
	    } else
1210
		axis_tick = axis_base - 
1212
		axis_tick = axis_base -
1211
		    GConvertXUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
1213
		    GConvertXUnits(Rf_gpptr(dd)->tcl, LINES, NFC, dd);
1212
	}
1214
	}
1213
	if (doticks) {
1215
	if (doticks) {
1214
	    Rf_gpptr(dd)->col = col;/*was fg */
1216
	    Rf_gpptr(dd)->col = col;/*was fg */
1215
	    GLine(axis_base, axis_low, axis_base, axis_high, NFC, dd);
1217
	    GLine(axis_base, axis_low, axis_base, axis_high, NFC, dd);
Line 3064... Line 3066...
3064
	    /* can't use warning because we want to print immediately  */
3066
	    /* can't use warning because we want to print immediately  */
3065
	    /* might want to handle warn=2? */
3067
	    /* might want to handle warn=2? */
3066
	    warn = asInteger(GetOption(install("warn"), R_NilValue));
3068
	    warn = asInteger(GetOption(install("warn"), R_NilValue));
3067
	    if (dmin > THRESHOLD) {
3069
	    if (dmin > THRESHOLD) {
3068
	        if(warn >= 0)
3070
	        if(warn >= 0)
3069
		    REprintf("warning: no point with %.2f inches\n", 
3071
		    REprintf("warning: no point with %.2f inches\n",
3070
                                        THRESHOLD);
3072
                                        THRESHOLD);
3071
	    }
3073
	    }
3072
	    else if (LOGICAL(ind)[imin]) {
3074
	    else if (LOGICAL(ind)[imin]) {
3073
	        if(warn >= 0 )
3075
	        if(warn >= 0 )
3074
		    REprintf("warning: nearest point already identified\n");
3076
		    REprintf("warning: nearest point already identified\n");
Line 3335... Line 3337...
3335
}
3337
}
3336
 
3338
 
3337
SEXP do_dendwindow(SEXP call, SEXP op, SEXP args, SEXP env)
3339
SEXP do_dendwindow(SEXP call, SEXP op, SEXP args, SEXP env)
3338
{
3340
{
3339
    int i, imax, n;
3341
    int i, imax, n;
3340
    double pin, *ll, tmp, yval, *y, ymin, ymax, yrange;
3342
    double pin, *ll, tmp, yval, *y, ymin, ymax, yrange, m;
3341
    SEXP originalArgs, merge, height, llabels, str;
3343
    SEXP originalArgs, merge, height, llabels, str;
3342
    char *vmax;
3344
    char *vmax;
3343
    DevDesc *dd;
3345
    DevDesc *dd;
-
 
3346
 
3344
    dd = CurrentDevice();
3347
    dd = CurrentDevice();
3345
    GCheckState(dd);
3348
    GCheckState(dd);
3346
    originalArgs = args;
3349
    originalArgs = args;
3347
    if (length(args) < 6)
3350
    if (length(args) < 6)
3348
	errorcall(call, "too few arguments");
3351
	errorcall(call, "too few arguments");
Line 3374... Line 3377...
3374
    GSavePars(dd);
3377
    GSavePars(dd);
3375
    ProcessInlinePars(args, dd, call);
3378
    ProcessInlinePars(args, dd, call);
3376
    Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * Rf_gpptr(dd)->cex;
3379
    Rf_gpptr(dd)->cex = Rf_gpptr(dd)->cexbase * Rf_gpptr(dd)->cex;
3377
    dnd_offset = GStrWidth("m", INCHES, dd);
3380
    dnd_offset = GStrWidth("m", INCHES, dd);
3378
    vmax = vmaxget();
3381
    vmax = vmaxget();
3379
    y =	 (double*)R_alloc(n, sizeof(double));
3382
    y =  (double*)R_alloc(n, sizeof(double));
3380
    ll =  (double*)R_alloc(n, sizeof(double));
3383
    ll = (double*)R_alloc(n, sizeof(double));
3381
    dnd_lptr = &(INTEGER(merge)[0]);
3384
    dnd_lptr = &(INTEGER(merge)[0]);
3382
    dnd_rptr = &(INTEGER(merge)[n]);
3385
    dnd_rptr = &(INTEGER(merge)[n]);
3383
    ymin = REAL(height)[0];
3386
    ymax = ymin = REAL(height)[0];
-
 
3387
    for (i = 1; i < n; i++) {
3384
    ymax = REAL(height)[n - 1];
3388
	m = REAL(height)[i];
-
 
3389
	if (m > ymax)
-
 
3390
	    ymax = m;
-
 
3391
	else if (m < ymin)
-
 
3392
	    ymin = m;
-
 
3393
    }
3385
    pin = Rf_gpptr(dd)->pin[1];
3394
    pin = Rf_gpptr(dd)->pin[1];
3386
    for (i = 0; i < n; i++) {
3395
    for (i = 0; i < n; i++) {
3387
	str = STRING_ELT(llabels, i);
3396
	str = STRING_ELT(llabels, i);
3388
	ll[i] = (str == NA_STRING) ? 0.0 :
3397
	ll[i] = (str == NA_STRING) ? 0.0 :
3389
	    GStrWidth(CHAR(str), INCHES, dd) + dnd_offset;
3398
	    GStrWidth(CHAR(str), INCHES, dd) + dnd_offset;