1 /*
2 # integer utilities
3 # (c) 2016 - 2017 Jens Oehlschlägel
4 # Licence: GPL2
5 # Provided 'as is', use at your own risk
6 */
7
8 #include <R.h>
9 #include <Rinternals.h>
10
11 // remember that NA_INTEGER==-2147483648
12 // and the allowed range of R's integer is -2147483647..-2147483647
13
14 // SEXP R_get_refcnt(SEXP x_){
15 // SEXP y_;
16 // PROTECT( y_ = allocVector(INTSXP,1) );
17 // INTEGER(y_)[0] = NAMED(x_);
18 // UNPROTECT(1);
19 // return(y_);
20 // }
21
22 // SEXP R_set_refcnt(SEXP x_, SEXP refcnt_){
23 // int refcnt = asInteger(refcnt_);
24 // PROTECT(x_);
25 // SET_NAMED(x_, refcnt);
26 // UNPROTECT(1);
27 // return(R_NilValue);
28 // }
29
30 // SEXP R_bit_named(SEXP x){
31 // SEXP ret_;
32 // PROTECT( ret_ = allocVector(INTSXP,1) );
33 // INTEGER(ret_)[0] = NAMED(x);
34 // UNPROTECT(1);
35 // return ret_;
36 // }
37
38
R_bitwhich_representation(SEXP x_)39 SEXP R_bitwhich_representation(SEXP x_){
40 SEXP ret_;
41 if (TYPEOF(x_) == LGLSXP){
42 if (LENGTH(x_)){
43 PROTECT( ret_ = allocVector(LGLSXP,1));
44 LOGICAL(ret_)[0] = LOGICAL(x_)[0];
45 }else{
46 PROTECT( ret_ = allocVector(LGLSXP,0));
47 }
48 }else{
49 PROTECT( ret_ = allocVector(INTSXP,1));
50 if (INTEGER(x_)[0]<0)
51 INTEGER(ret_)[0] = -1;
52 else
53 INTEGER(ret_)[0] = 1;
54 }
55 UNPROTECT(1);
56 return(ret_);
57 }
58
R_get_length(SEXP x_)59 SEXP R_get_length(SEXP x_){
60 SEXP y_;
61 PROTECT( y_ = allocVector(INTSXP,1));
62 INTEGER(y_)[0] = LENGTH(x_);
63 UNPROTECT(1);
64 return(y_);
65 }
66
R_still_identical(SEXP x_,SEXP y_)67 SEXP R_still_identical(
68 SEXP x_
69 , SEXP y_
70 )
71 {
72 SEXP ret_;
73 Rboolean ret;
74 if(!isVectorAtomic(x_)){
75 error("SEXP is not atomic vector");
76 return R_NilValue;
77 }
78 if (TYPEOF(x_)!=TYPEOF(y_)){
79 error("vectors don't have identic type");
80 return R_NilValue;
81 }
82 //somehow is DATAPTR not declared: ret = DATAPTR(x_)==DATAPTR(y_) ? TRUE : FALSE;
83 switch (TYPEOF(x_)) {
84 case CHARSXP:
85 ret = CHAR(x_)==CHAR(y_) ? TRUE : FALSE;
86 break;
87 case LGLSXP:
88 ret = LOGICAL(x_)==LOGICAL(y_) ? TRUE : FALSE;
89 case INTSXP:
90 ret = INTEGER(x_)==INTEGER(y_) ? TRUE : FALSE;
91 break;
92 case REALSXP:
93 ret = REAL(x_)==REAL(y_) ? TRUE : FALSE;
94 break;
95 case CPLXSXP:
96 ret = COMPLEX(x_)==COMPLEX(y_) ? TRUE : FALSE;
97 break;
98 case STRSXP:
99 ret = STRING_PTR(x_)==STRING_PTR(y_) ? TRUE : FALSE;
100 break;
101 case VECSXP:
102 ret = VECTOR_PTR(x_)==VECTOR_PTR(y_) ? TRUE : FALSE;
103 case RAWSXP:
104 ret = RAW(x_)==RAW(y_) ? TRUE : FALSE;
105 break;
106 default:
107 error("unimplemented type in truly.identical");
108 return R_NilValue;
109 }
110 if (LENGTH(x_)!=LENGTH(y_)){
111 ret = FALSE;
112 }
113 PROTECT( ret_ = allocVector(LGLSXP, 1) );
114 INTEGER(ret_)[0] = ret;
115 UNPROTECT(1);
116 return ret_;
117 }
118
119
R_copy_vector(SEXP x_,SEXP revx_)120 SEXP R_copy_vector(SEXP x_, SEXP revx_){
121 SEXP y_;
122 int revx = asLogical(revx_);
123 int i, j, n=LENGTH(x_);
124 int *intx, *inty;
125 double *realx, *realy;
126 if(!isVectorAtomic(x_)){
127 error("SEXP is not atomic vector");
128 }
129 switch(TYPEOF(x_)) {
130 case REALSXP:
131 PROTECT( y_ = allocVector(REALSXP,n) );
132 realx = REAL(x_);
133 realy = REAL(y_);
134 if (revx)
135 for (i=0,j=n-1;i<n;i++,j--)
136 realy[i] = -realx[j];
137 else
138 for (i=0;i<n;i++)
139 realy[i] = realx[i];
140 break;
141 case LGLSXP:
142 PROTECT( y_ = allocVector(LGLSXP,n) );
143 intx = LOGICAL(x_);
144 inty = LOGICAL(y_);
145 if (revx)
146 for (i=0,j=n-1;i<n;i++,j--)
147 inty[i] = -intx[j];
148 else
149 for (i=0;i<n;i++)
150 inty[i] = intx[i];
151 break;
152 case INTSXP:
153 PROTECT( y_ = allocVector(INTSXP,n) );
154 intx = INTEGER(x_);
155 inty = INTEGER(y_);
156 if (revx)
157 for (i=0,j=n-1;i<n;i++,j--)
158 inty[i] = -intx[j];
159 else
160 for (i=0;i<n;i++)
161 inty[i] = intx[i];
162 break;
163 case CPLXSXP:
164 case STRSXP:
165 default:
166 error("non-implemented type in copy_vector");
167 }
168 UNPROTECT(1);
169 return(y_);
170 }
171
172
R_reverse_vector(SEXP x_)173 SEXP R_reverse_vector(SEXP x_){
174 SEXP y_;
175 int i, j, n=LENGTH(x_);
176 int *intx, *inty;
177 double *realx, *realy;
178 if(!isVectorAtomic(x_)){
179 error("SEXP is not atomic vector");
180 }
181 switch(TYPEOF(x_)) {
182 case REALSXP:
183 PROTECT( y_ = allocVector(REALSXP,n) );
184 realx = REAL(x_);
185 realy = REAL(y_);
186 for (i=0,j=n-1;i<n;i++,j--)
187 realy[i] = realx[j];
188 break;
189 case LGLSXP:
190 PROTECT( y_ = allocVector(LGLSXP,n) );
191 intx = LOGICAL(x_);
192 inty = LOGICAL(y_);
193 for (i=0,j=n-1;i<n;i++,j--)
194 inty[i] = intx[j];
195 break;
196 case INTSXP:
197 PROTECT( y_ = allocVector(INTSXP,n) );
198 intx = INTEGER(x_);
199 inty = INTEGER(y_);
200 for (i=0,j=n-1;i<n;i++,j--)
201 inty[i] = intx[j];
202 break;
203 case CPLXSXP:
204 case STRSXP:
205 default:
206 error("non-implemented type in reverse_vector");
207 }
208 UNPROTECT(1);
209 return(y_);
210 }
211
212
213
214
R_firstNA(SEXP x_)215 SEXP R_firstNA(SEXP x_){
216 SEXP y_;
217 int i, n=LENGTH(x_);
218 int *intx;
219 double *realx;
220 PROTECT( y_ = allocVector(INTSXP,1) );
221 int *y = INTEGER(y_);
222 y[0] = 0;
223 switch(TYPEOF(x_)) {
224 case REALSXP:
225 realx = REAL(x_);
226 for (i=0;i<n;i++){
227 if (ISNA(realx[i])){
228 y[0] = i+1;
229 break;
230 }
231 }
232 break;
233 case LGLSXP:
234 intx = LOGICAL(x_);
235 for (i=0;i<n;i++){
236 if (intx[i] == NA_LOGICAL){
237 y[0] = i+1;
238 break;
239 }
240 }
241 break;
242 case INTSXP:
243 intx = INTEGER(x_);
244 for (i=0;i<n;i++){
245 if (intx[i] == NA_INTEGER){
246 y[0] = i+1;
247 break;
248 }
249 }
250 break;
251 case CPLXSXP:
252 case STRSXP:
253 default:
254 error("non-implemented type in firstNA");
255 }
256 UNPROTECT(1);
257 return(y_);
258 }
259
260
261 // determine min, max and number of NAs
R_range_na(SEXP x_)262 SEXP R_range_na(SEXP x_){
263 int *x = INTEGER(x_);
264 SEXP ret_;
265 PROTECT( ret_ = allocVector(INTSXP,3) );
266 int *ret = INTEGER(ret_);
267 int i, n=LENGTH(x_);
268 int min=NA_INTEGER;
269 int max=NA_INTEGER;
270 int countna=0;
271 register int t;
272 for (i=0; i<n; i++){
273 if (x[i] == NA_INTEGER)
274 countna++;
275 else{
276 min = x[i];
277 max = x[i];
278 break;
279 }
280 }
281 for ( ; i<n; i++){
282 t = x[i];
283 if (t<min){
284 if (t == NA_INTEGER)
285 countna++;
286 else
287 min = t;
288 }else if (t>max)
289 max = t;
290 }
291 ret[0] = min;
292 ret[1] = max;
293 ret[2] = countna;
294 UNPROTECT(1);
295 return(ret_);
296 }
297
298 // dito but copy all of x_ but zero to y_
299 // and return y_ with range_na as attribute
R_range_nanozero(SEXP x_)300 SEXP R_range_nanozero(SEXP x_){
301 int ix, iy, n=LENGTH(x_);
302 int min=NA_INTEGER;
303 int max=NA_INTEGER;
304 int countna=0;
305 SEXP y_,ret_;
306 PROTECT( ret_ = allocVector(INTSXP,3) );
307 PROTECT( y_ = allocVector(INTSXP,n) );
308 int *x = INTEGER(x_);
309 int *y = INTEGER(y_);
310 int *ret = INTEGER(ret_);
311 register int t;
312 for (ix=0,iy=0; ix<n; ix++){
313 if (x[ix] == NA_INTEGER){
314 y[iy++] = x[ix];
315 countna++;
316 }else if(x[ix]!=0){
317 min = x[ix];
318 max = x[ix];
319 y[iy++] = x[ix++];
320 break;
321 }
322 }
323 for ( ; ix<n; ix++){
324 t = x[ix];
325 if (t!=0){
326 y[iy++] = t;
327 if (t<min){
328 if (t == NA_INTEGER)
329 countna++;
330 else
331 min = t;
332 }else if (t>max){
333 max = t;
334 }
335 }
336 }
337 if (iy<ix){
338 SETLENGTH(y_, iy);
339 }
340 ret[0] = min;
341 ret[1] = max;
342 ret[2] = countna;
343
344 setAttrib(y_, install("range_na"), ret_);
345 UNPROTECT(2);
346 return(y_);
347 }
348
349 // determine min, max, sort NAs to one end (and count them), determine (un)sortedness
350 // and return y_ with range_na as attribute (min,max,sumNA,isUnsorted)
R_range_sortna(SEXP x_,SEXP decreasing_,SEXP na_last_)351 SEXP R_range_sortna(SEXP x_, SEXP decreasing_, SEXP na_last_){
352 int ix, iy, n=LENGTH(x_);
353 int na_last = asLogical(na_last_);
354 int decreasing = asLogical(decreasing_);
355 int min=NA_INTEGER;
356 int max=NA_INTEGER;
357 int countna=0;
358 int unsorted=FALSE;
359 SEXP y_,ret_;
360 PROTECT( ret_ = allocVector(INTSXP,4) );
361 PROTECT( y_ = allocVector(INTSXP,n) );
362 int *x = INTEGER(x_);
363 int *y = INTEGER(y_);
364 int *ret = INTEGER(ret_);
365 register int t, last=0; // zero assignment just to quiet compiler
366
367 if (na_last == FALSE){
368 // all NAs to start
369 for (ix=n-1,iy=n; ix>=0; ix--){
370 if (x[ix] != NA_INTEGER){
371 min = x[ix];
372 max = x[ix];
373 last = x[ix];
374 y[--iy] = x[ix--];
375 break;
376 }
377 }
378 if (decreasing)
379 for ( ; ix>=0; ix--){
380 t = x[ix];
381 if (t != NA_INTEGER){
382 y[--iy] = t;
383 if (t<min){
384 min = t;
385 }else if (t>max){
386 max = t;
387 }
388 if (t < last){
389 unsorted = TRUE;
390 ix--;
391 break;
392 }
393 last = t;
394 }
395 }
396 else
397 for ( ; ix>=0; ix--){
398 t = x[ix];
399 if (t != NA_INTEGER){
400 y[--iy] = t;
401 if (t<min){
402 min = t;
403 }else if (t>max){
404 max = t;
405 }
406 if (t > last){
407 unsorted = TRUE;
408 ix--;
409 break;
410 }
411 last = t;
412 }
413 }
414 for ( ; ix>=0; ix--){
415 t = x[ix];
416 if (t != NA_INTEGER){
417 y[--iy] = t;
418 if (t<min){
419 min = t;
420 }else if (t>max){
421 max = t;
422 }
423 }
424 }
425 countna = iy;
426 while(iy>0){
427 y[--iy] = NA_INTEGER;
428 }
429 }else{
430 // all nonNA to start
431 for (ix=0,iy=0; ix<n; ix++){
432 if (x[ix] != NA_INTEGER){
433 min = x[ix];
434 max = x[ix];
435 last = x[ix];
436 y[iy++] = x[ix++];
437 break;
438 }
439 }
440 if (decreasing)
441 for ( ; ix<n; ix++){
442 t = x[ix];
443 if (t != NA_INTEGER){
444 y[iy++] = t;
445 if (t<min){
446 min = t;
447 }else if (t>max){
448 max = t;
449 }
450 if (t > last){
451 unsorted = TRUE;
452 ix++;
453 break;
454 }
455 last = t;
456 }
457 }
458 else
459 for ( ; ix<n; ix++){
460 t = x[ix];
461 if (t != NA_INTEGER){
462 y[iy++] = t;
463 if (t<min){
464 min = t;
465 }else if (t>max){
466 max = t;
467 }
468 if (t < last){
469 unsorted = TRUE;
470 ix++;
471 break;
472 }
473 last = t;
474 }
475 }
476 for ( ; ix<n; ix++){
477 t = x[ix];
478 if (t != NA_INTEGER){
479 y[iy++] = t;
480 if (t<min){
481 min = t;
482 }else if (t>max){
483 max = t;
484 }
485 }
486 }
487 if (na_last == NA_INTEGER){
488 // drop all NAs
489 countna = 0;
490 SETLENGTH(y_, iy);
491 }else{
492 // all NAs to end
493 countna = n - iy;
494 while(iy<n){
495 y[iy++] = NA_INTEGER;
496 }
497 }
498 }
499 ret[0] = min;
500 ret[1] = max;
501 ret[2] = countna;
502 ret[3] = unsorted;
503
504 setAttrib(y_, install("range_sortna"), ret_);
505 UNPROTECT(2);
506 return(y_);
507 }
508
509