forked from Rdatatable/data.table
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathbetween.c
More file actions
104 lines (86 loc) · 3.79 KB
/
between.c
File metadata and controls
104 lines (86 loc) · 3.79 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
#include "data.table.h"
#include <Rdefines.h>
static double l=0.0, u=0.0;
Rboolean int_upper_closed(SEXP x, R_len_t i) {
return (INTEGER(x)[i] == NA_INTEGER || (double)INTEGER(x)[i] <= u ? NA_LOGICAL : FALSE);
}
Rboolean int_upper_open(SEXP x, R_len_t i) {
return (INTEGER(x)[i] == NA_INTEGER || (double)INTEGER(x)[i] < u ? NA_LOGICAL : FALSE);
}
Rboolean int_lower_closed(SEXP x, R_len_t i) {
return (INTEGER(x)[i] == NA_INTEGER || (double)INTEGER(x)[i] >= l ? NA_LOGICAL : FALSE);
}
Rboolean int_lower_open(SEXP x, R_len_t i) {
return (INTEGER(x)[i] == NA_INTEGER || (double)INTEGER(x)[i] > l ? NA_LOGICAL : FALSE);
}
Rboolean int_both_closed(SEXP x, R_len_t i) {
return (INTEGER(x)[i] == NA_INTEGER ? NA_LOGICAL : ((double)INTEGER(x)[i] >= l && (double)INTEGER(x)[i] <= u));
}
Rboolean int_both_open(SEXP x, R_len_t i) {
return (INTEGER(x)[i] == NA_INTEGER ? NA_LOGICAL : ((double)INTEGER(x)[i] > l && (double)INTEGER(x)[i] < u));
}
Rboolean double_upper_closed(SEXP x, R_len_t i) {
return (ISNAN(REAL(x)[i]) || REAL(x)[i] <= u ? NA_LOGICAL : FALSE);
}
Rboolean double_upper_open(SEXP x, R_len_t i) {
return (ISNAN(REAL(x)[i]) || REAL(x)[i] < u ? NA_LOGICAL : FALSE);
}
Rboolean double_lower_closed(SEXP x, R_len_t i) {
return (ISNAN(REAL(x)[i]) || REAL(x)[i] >= l ? NA_LOGICAL : FALSE);
}
Rboolean double_lower_open(SEXP x, R_len_t i) {
return (ISNAN(REAL(x)[i]) || REAL(x)[i] > l ? NA_LOGICAL : FALSE);
}
Rboolean double_both_closed(SEXP x, R_len_t i) {
return (ISNAN(REAL(x)[i]) ? NA_LOGICAL : (REAL(x)[i] >= l && REAL(x)[i] <= u));
}
Rboolean double_both_open(SEXP x, R_len_t i) {
return (ISNAN(REAL(x)[i]) ? NA_LOGICAL : (REAL(x)[i] > l && REAL(x)[i] < u));
}
SEXP between(SEXP x, SEXP lower, SEXP upper, SEXP bounds) {
R_len_t i, nx = length(x), nl = length(lower), nu = length(upper);
l = 0.0; u = 0.0;
SEXP ans;
Rboolean (*flower)(), (*fupper)(), (*fboth)();
if (!nx || !nl || !nu)
return (allocVector(LGLSXP, 0));
if (nl != 1 && nl != nx)
error("length(lower) (%d) must be either 1 or length(x) (%d)", nl, nx);
if (nu != 1 && nu != nx)
error("length(upper) (%d) must be either 1 or length(x) (%d)", nu, nx);
if (!isLogical(bounds) || LOGICAL(bounds)[0] == NA_LOGICAL)
error("incbounds must be logical TRUE/FALSE.");
// no support for int64 yet (only handling most common cases)
// coerce to also get NA values properly
lower = PROTECT(coerceVector(lower, REALSXP)); l = REAL(lower)[0];
upper = PROTECT(coerceVector(upper, REALSXP)); u = REAL(upper)[0];
ans = PROTECT(allocVector(LGLSXP, nx));
if (LOGICAL(bounds)[0]) {
fupper = isInteger(x) ? &int_upper_closed : &double_upper_closed;
flower = isInteger(x) ? &int_lower_closed : &double_lower_closed;
fboth = isInteger(x) ? &int_both_closed : &double_both_closed;
} else {
fupper = isInteger(x) ? &int_upper_open : &double_upper_open;
flower = isInteger(x) ? &int_lower_open : &double_lower_open;
fboth = isInteger(x) ? &int_both_open : &double_both_open;
}
if ( ISNAN(REAL(lower)[0]) ) {
if ( ISNAN(REAL(upper)[0]) ) {
#pragma omp parallel for num_threads(getDTthreads())
for (i=0; i<nx; i++) LOGICAL(ans)[i] = NA_LOGICAL;
} else {
#pragma omp parallel for num_threads(getDTthreads())
for (i=0; i<nx; i++) LOGICAL(ans)[i] = fupper(x, i);
}
} else {
if ( ISNAN(REAL(upper)[0]) ) {
#pragma omp parallel for num_threads(getDTthreads())
for (i=0; i<nx; i++) LOGICAL(ans)[i] = flower(x, i);
} else {
#pragma omp parallel for num_threads(getDTthreads())
for (i=0; i<nx; i++) LOGICAL(ans)[i] = fboth(x, i);
}
}
UNPROTECT(3);
return(ans);
}