1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
4 * Copyright (C) 1997--2013 The R Core Team
5 * Copyright (C) 2002--2005 The R Foundation
6 *
7 * 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 * the Free Software Foundation; either version 2 of the License, or
10 * (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
16 *
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, a copy is available at
19 * https://www.R-project.org/Licenses/
20
21
22 * This is (a small part of) an extensive reworking by Paul Murrell
23 * of an original quick hack by Ross Ihaka designed to give a
24 * superset of the functionality in the AT&T Bell Laboratories GRZ
25 * library.
26 *
27 */
28
29
30 #ifdef HAVE_CONFIG_H
31 #include <config.h>
32 #endif
33
34 #include <Defn.h>
35 #include <Graphics.h>
36 #include <GraphicsBase.h>
37 #include <R_ext/GraphicsEngine.h>
38
39 #ifdef ENABLE_NLS
40 #include <libintl.h>
41 #undef _
42 #define _(String) dgettext ("grDevices", String)
43 #else
44 #define _(String) (String)
45 #endif
46
47
48 #define checkArity_length \
49 args = CDR(args); \
50 if(!LENGTH(CAR(args))) \
51 error(_("argument must have positive length"))
52
devcontrol(SEXP args)53 SEXP devcontrol(SEXP args)
54 {
55 int listFlag;
56 pGEDevDesc gdd = GEcurrentDevice();
57
58 args = CDR(args);
59 listFlag = asLogical(CAR(args));
60 if(listFlag == NA_LOGICAL) error(_("invalid argument"));
61 GEinitDisplayList(gdd);
62 gdd->displayListOn = listFlag ? TRUE: FALSE;
63 return ScalarLogical(listFlag);
64 }
65
devdisplaylist(SEXP args)66 SEXP devdisplaylist(SEXP args)
67 {
68 pGEDevDesc gdd = GEcurrentDevice();
69 return ScalarLogical(gdd->displayListOn);
70 }
71
devcopy(SEXP args)72 SEXP devcopy(SEXP args)
73 {
74 checkArity_length;
75 GEcopyDisplayList(INTEGER(CAR(args))[0] - 1);
76 return R_NilValue;
77 }
78
devcur(SEXP args)79 SEXP devcur(SEXP args)
80 {
81 args = CDR(args);
82 return ScalarInteger(curDevice() + 1);
83 }
84
devnext(SEXP args)85 SEXP devnext(SEXP args)
86 {
87 checkArity_length;
88 int nxt = INTEGER(CAR(args))[0];
89 if (nxt == NA_INTEGER) error(_("NA argument is invalid"));
90 return ScalarInteger( nextDevice(nxt - 1) + 1 );
91 }
92
devprev(SEXP args)93 SEXP devprev(SEXP args)
94 {
95 checkArity_length;
96 int prev = INTEGER(CAR(args))[0];
97 if (prev == NA_INTEGER) error(_("NA argument is invalid"));
98 return ScalarInteger( prevDevice(prev - 1) + 1 );
99 }
100
devset(SEXP args)101 SEXP devset(SEXP args)
102 {
103 checkArity_length;
104 int devNum = INTEGER(CAR(args))[0];
105 if (devNum == NA_INTEGER) error(_("NA argument is invalid"));
106 return ScalarInteger( selectDevice(devNum - 1) + 1 );
107 }
108
devoff(SEXP args)109 SEXP devoff(SEXP args)
110 {
111 checkArity_length;
112 killDevice(INTEGER(CAR(args))[0] - 1);
113 return R_NilValue;
114 }
115
devsize(SEXP args)116 SEXP devsize(SEXP args)
117 {
118 SEXP ans;
119 pDevDesc dd = GEcurrentDevice()->dev;
120 double left, right, bottom, top;
121
122 dd->size(&left, &right, &bottom, &top, dd);
123 ans = allocVector(REALSXP, 2);
124 REAL(ans)[0] = fabs(right - left);
125 REAL(ans)[1] = fabs(bottom - top);
126 return ans;
127 }
128
devholdflush(SEXP args)129 SEXP devholdflush(SEXP args)
130 {
131 pDevDesc dd = GEcurrentDevice()->dev;
132
133 args = CDR(args);
134 int level = asInteger(CAR(args));
135 if(dd->holdflush && level != NA_INTEGER) level = (dd->holdflush(dd, level));
136 else level = 0;
137 return ScalarInteger(level);
138 }
139
devcap(SEXP args)140 SEXP devcap(SEXP args)
141 {
142 SEXP ans;
143 int i = 0;
144 pDevDesc dd = GEcurrentDevice()->dev;
145
146 args = CDR(args);
147
148 PROTECT(ans = allocVector(INTSXP, 9));
149 INTEGER(ans)[i] = dd->haveTransparency;
150 INTEGER(ans)[++i] = dd->haveTransparentBg;
151 /* These will be NULL if the device does not define them */
152 INTEGER(ans)[++i] = (dd->raster != NULL) ? dd->haveRaster : 1;
153 INTEGER(ans)[++i] = (dd->cap != NULL) ? dd->haveCapture : 1;
154 INTEGER(ans)[++i] = (dd->locator != NULL) ? dd->haveLocator : 1;
155 INTEGER(ans)[++i] = (int)(dd->canGenMouseDown);
156 INTEGER(ans)[++i] = (int)(dd->canGenMouseMove);
157 INTEGER(ans)[++i] = (int)(dd->canGenMouseUp);
158 INTEGER(ans)[++i] = (int)(dd->canGenKeybd);
159 /* FIXME: there should be a way for a device to declare its own
160 events, and return information on how to set them */
161
162 UNPROTECT(1);
163 return ans;
164 }
165
devcapture(SEXP args)166 SEXP devcapture(SEXP args)
167 {
168 int i, col, row, nrow, ncol, size;
169 Rboolean native;
170 pGEDevDesc gdd = GEcurrentDevice();
171 int *rint;
172 SEXP raster, image, idim;
173
174 args = CDR(args);
175
176 native = asLogical(CAR(args));
177 if (native != TRUE) native = FALSE;
178
179 raster = GECap(gdd);
180 if (isNull(raster)) /* NULL = unsupported */
181 return raster;
182
183 PROTECT(raster);
184 if (native) {
185 setAttrib(raster, R_ClassSymbol, mkString("nativeRaster"));
186 UNPROTECT(1);
187 return raster;
188 }
189
190 /* non-native, covert to color strings (this is based on grid.cap) */
191 size = LENGTH(raster);
192 nrow = INTEGER(getAttrib(raster, R_DimSymbol))[0];
193 ncol = INTEGER(getAttrib(raster, R_DimSymbol))[1];
194
195 PROTECT(image = allocVector(STRSXP, size));
196 rint = INTEGER(raster);
197 for (i = 0; i < size; i++) {
198 col = i % ncol + 1;
199 row = i / ncol + 1;
200 SET_STRING_ELT(image, (col - 1) * nrow + row - 1,
201 mkChar(col2name(rint[i])));
202 }
203
204 PROTECT(idim = allocVector(INTSXP, 2));
205 INTEGER(idim)[0] = nrow;
206 INTEGER(idim)[1] = ncol;
207 setAttrib(image, R_DimSymbol, idim);
208 UNPROTECT(3);
209
210 return image;
211 }
212