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