/*
* Initialize settings with default values; why did we end up deciding to use
* all the 2^n - 1 values?
*/
struct VALC_settings VALC_settings_init() {
return (struct VALC_settings) {
.type_mode = 0,
.attr_mode = 0,
.lang_mode = 0,
.fun_mode = 0,
.fuzzy_int_max_len = 100,
.suppress_warnings = 0,
.in_attr = 0,
.env = R_NilValue,
.width = -1,
.env_depth_max = 65535L,
.symb_sub_depth_max = 65535L,
.nchar_max = 65535L,
.symb_size_max = 15000L,
.track_hash_content_size = 63L,
.result_list_size_init = 64L,
.result_list_size_max = 2048L
};
}
/*
* Check that a SEXP could pass as a scalar integer and return it as a long
*/
static long VALC_is_scalar_int(
SEXP x, const char * x_name, int x_min, int x_max
) {
SEXPTYPE x_type = TYPEOF(x);
if(x_type != REALSXP && x_type != INTSXP)
error(
"Setting `%s` must be integer-like (is %s).", x_name, type2char(x_type)
);
// Despite L notation, R integers are just ints, but there are checks to
// ensure ints are 32 bits on compilation and such
int x_int = asInteger(x);
if(xlength(x) != 1)
error(
"Setting `%s` must be scalar integer (is length %zu).", x_name,
xlength(x)
);
if(x_int == NA_INTEGER) error("Setting `%s` may not be NA.", x_name);
if(TYPEOF(x) == REALSXP) {
if(x_int != asReal(x)) error("Setting `%s` must be integer like.", x_name);
}
if(x_int < x_min || x_int > x_max)
error(
"Setting `%s` must be scalar integer between %d and %d (is %d).",
x_name, x_min, x_max, x_int
);
return x_int;
}
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP s = CAR(args), ncopy = CADR(args);
R_xlen_t nc;
SEXP a;
if (!isVector(ncopy))
error(_("incorrect type for second argument"));
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate an object of type '%s'"),
type2char(TYPEOF(s)));
nc = xlength(ncopy); // might be 0
if (nc == xlength(s))
PROTECT(a = rep2(s, ncopy));
else {
if (nc != 1) error(_("invalid '%s' value"), "times");
#ifdef LONG_VECTOR_SUPPORT
double snc = asReal(ncopy);
if (!R_FINITE(snc) || snc < 0)
error(_("invalid '%s' value"), "times");
nc = (R_xlen_t) snc;
#else
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid '%s' value"), "times");
#endif
R_xlen_t ns = xlength(s);
PROTECT(a = rep3(s, ns, nc * ns));
}
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
/* This is used for [[ and [[<- with a vector of indices of length > 1 .
x is a list or pairlist, and it is indexed recusively from
level start to level stop-1. ( 0...len-1 or 0..len-2 then len-1).
For [[<- it needs to duplicate if substructure might be shared.
*/
SEXP attribute_hidden
vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,
Rboolean dup)
{
int i;
R_xlen_t offset;
SEXP cx;
/* sanity check */
if (dup && MAYBE_SHARED(x))
error("should only be called in an assignment context.");
for(i = start; i < stop; i++) {
if(!isVectorList(x) && !isPairList(x)) {
if (i)
errorcall(call, _("recursive indexing failed at level %d\n"), i+1);
else
errorcall(call, _("attempt to select more than one element"));
}
PROTECT(x);
SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, names,
xlength(x), pok, i, call);
UNPROTECT(2); /* x, names */
if(offset < 0 || offset >= xlength(x))
errorcall(call, _("no such index at level %d\n"), i+1);
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
cx = nthcdr(x, (int) offset);
if (NAMED(x) > NAMED(CAR(cx)))
SET_NAMED(CAR(x), NAMED(x));
x = CAR(cx);
if (dup && MAYBE_SHARED(x)) {
x = shallow_duplicate(x);
SETCAR(cx, x);
}
} else {
cx = x;
x = VECTOR_ELT(x, offset);
if (NAMED(cx) > NAMED(x))
SET_NAMED(x, NAMED(cx));
if (dup && MAYBE_SHARED(x)) {
x = shallow_duplicate(x);
SET_VECTOR_ELT(cx, offset, x);
}
}
}
return x;
}
static void checkNames(SEXP x, SEXP s)
{
if (isVector(x) || isList(x) || isLanguage(x)) {
if (!isVector(s) && !isList(s))
error(_("invalid type (%s) for 'names': must be vector"),
type2char(TYPEOF(s)));
if (xlength(x) != xlength(s))
error(_("'names' attribute [%d] must be the same length as the vector [%d]"), length(s), length(x));
}
else if(IS_S4_OBJECT(x)) {
/* leave validity checks to S4 code */
}
else error(_("names() applied to a non-vector"));
}
Rboolean all_nchar(SEXP x, const R_xlen_t n) {
if (!isString(x)) {
SEXP xs = PROTECT(coerceVector(x, STRSXP));
Rboolean res = all_nchar(xs, n);
UNPROTECT(1);
return res;
}
const R_xlen_t nx = xlength(x);
for (R_xlen_t i = 0; i < nx; i++) {
if (STRING_ELT(x, i) == NA_STRING || xlength(STRING_ELT(x, i)) < n)
return FALSE;
}
return TRUE;
}
SEXP meanOver(SEXP x, SEXP idxs, SEXP naRm, SEXP refine) {
SEXP ans;
R_xlen_t nx;
int narm, refine2;
double avg = NA_REAL;
/* Argument 'x': */
assertArgVector(x, (R_TYPE_INT | R_TYPE_REAL), "x");
nx = xlength(x);
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'refine': */
refine2 = asLogicalNoNA(refine, "refine");
/* Argument 'idxs': */
R_xlen_t nidxs;
int idxsType;
void *cidxs = validateIndices(idxs, nx, 1, &nidxs, &idxsType);
/* Double matrices are more common to use. */
if (isReal(x)) {
avg = meanOver_Real[idxsType](REAL(x), nx, cidxs, nidxs, narm, refine2);
} else if (isInteger(x)) {
avg = meanOver_Integer[idxsType](INTEGER(x), nx, cidxs, nidxs, narm, refine2);
}
/* Return results */
PROTECT(ans = allocVector(REALSXP, 1));
REAL(ans)[0] = avg;
UNPROTECT(1);
return(ans);
} // meanOver()
cholmod_sparse* get_cholmod_NNE(const int n_vertices,
const int n_edges,
const SEXP NNE_R,
cholmod_common* const cholmod_c) {
if (n_vertices * n_edges != xlength(NNE_R)) {
error("Supplied NNE does not match number vertices and block size.");
}
cholmod_sparse* out = cholmod_allocate_sparse(n_vertices, // rows
n_vertices, // cols
n_vertices * n_edges, // edges
false, // not sorted
true, // packed
false, //unsymmetric
CHOLMOD_PATTERN,
cholmod_c);
int* const p_ptr = static_cast<int*>(out->p);
p_ptr[0] = 0;
for (int i = 1; i <= n_vertices; ++i) {
p_ptr[i] = i * n_edges;
}
out->i = static_cast<void*>(INTEGER(NNE_R));
return out;
}
SEXP attribute_hidden strmat2intmat(SEXP s, SEXP dnamelist, SEXP call)
{
/* XXX: assumes all args are protected */
int nr = nrows(s), i, j, v;
R_xlen_t idx, NR = nr;
SEXP dnames, snames, si, sicol, s_elt;
PROTECT(snames = allocVector(STRSXP, nr));
PROTECT(si = allocVector(INTSXP, xlength(s)));
dimgets(si, getAttrib(s, R_DimSymbol));
for (i = 0; i < length(dnamelist); i++) {
dnames = VECTOR_ELT(dnamelist, i);
for (j = 0; j < nr; j++)
SET_STRING_ELT(snames, j, STRING_ELT(s, j + (i * NR)));
PROTECT(sicol = match(dnames, snames, 0));
for (j = 0; j < nr; j++) {
v = INTEGER(sicol)[j];
idx = j + (i * NR);
s_elt = STRING_ELT(s, idx);
if (s_elt == NA_STRING) v = NA_INTEGER;
if (!CHAR(s_elt)[0]) v = 0; /* disallow "" match */
if (v == 0) errorcall(call, _("subscript out of bounds"));
INTEGER(si)[idx] = v;
}
UNPROTECT(1);
}
UNPROTECT(2);
return si;
}
SEXP c_check_scalar(SEXP x, SEXP na_ok) {
Rboolean is_na = is_scalar_na(x);
if (xlength(x) != 1 || (!is_na && !isVectorAtomic(x)))
return make_type_error(x, "atomic scalar");
if (is_na && !asFlag(na_ok, "na.ok"))
return make_result("May not be NA");
return ScalarLogical(TRUE);
}
static Rboolean any_nan_list(SEXP x) {
const R_xlen_t nx = xlength(x);
for (R_xlen_t i = 0; i < nx; i++) {
if (any_nan(VECTOR_ELT(x, i)))
return TRUE;
}
return FALSE;
}
SEXP weightedMedian(SEXP x, SEXP w, SEXP idxs, SEXP naRm, SEXP interpolate, SEXP ties) {
SEXP ans;
int narm, interpolate2, ties2;
double mu = NA_REAL;
R_xlen_t nx, nw;
/* Argument 'x': */
assertArgVector(x, (R_TYPE_INT | R_TYPE_REAL), "x");
nx = xlength(x);
/* Argument 'x': */
assertArgVector(w, (R_TYPE_REAL), "w");
nw = xlength(w);
if (nx != nw) {
error("Argument 'x' and 'w' are of different lengths: %d != %d", nx, nw);
}
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'interpolate': */
interpolate2 = asLogicalNoNA(interpolate, "interpolate");
/* Argument 'idxs': */
R_xlen_t nidxs;
int idxsType;
void *cidxs = validateIndices(idxs, nx, 1, &nidxs, &idxsType);
/* Argument 'ties': */
ties2 = asInteger(ties);
/* Double matrices are more common to use. */
if (isReal(x)) {
mu = weightedMedian_Real[idxsType](REAL(x), nx, REAL(w), cidxs, nidxs, narm, interpolate2, ties2);
} else if (isInteger(x)) {
mu = weightedMedian_Integer[idxsType](INTEGER(x), nx, REAL(w), cidxs, nidxs, narm, interpolate2, ties2);
}
/* Return results */
PROTECT(ans = allocVector(REALSXP, 1));
REAL(ans)[0] = mu;
UNPROTECT(1);
return(ans);
} // weightedMedian()
static msg_t check_vector_len(SEXP x, SEXP len, SEXP min_len, SEXP max_len) {
if (!isNull(len)) {
R_xlen_t n = asCount(len, "len");
if (xlength(x) != n)
return make_msg("Must have length %g, but has length %g", (double)n, (double)xlength(x));
}
if (!isNull(min_len)) {
R_xlen_t n = asCount(min_len, "min.len");
if (xlength(x) < n)
return make_msg("Must have length >= %g, but has length %g", (double)n, (double)xlength(x));
}
if (!isNull(max_len)) {
R_xlen_t n = asCount(max_len, "max.len");
if (xlength(x) > n)
return make_msg("Must have length <= %g, but has length %g", (double)n, (double)xlength(x));
}
return MSGT;
}
SEXP attribute_hidden do_rep_len(SEXP call, SEXP op, SEXP args, SEXP rho)
{
R_xlen_t ns, na;
SEXP a, s, len;
checkArity(op, args);
s = CAR(args);
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate non-vector"));
len = CADR(args);
if(length(len) != 1)
error(_("invalid '%s' value"), "length.out");
#ifdef LONG_VECTOR_SUPPORT
double sna = asReal(len);
if (!R_FINITE(sna) || sna < 0)
error(_("invalid '%s' value"), "length.out");
na = (R_xlen_t) sna;
#else
if ((na = asInteger(len)) == NA_INTEGER || na < 0) /* na = 0 ok */
error(_("invalid '%s' value"), "length.out");
#endif
if (TYPEOF(s) == NILSXP && na > 0)
error(_("cannot replicate NULL to a non-zero length"));
ns = xlength(s);
if (ns == 0) {
SEXP a;
PROTECT(a = duplicate(s));
if(na > 0) a = xlengthgets(a, na);
UNPROTECT(1);
return a;
}
PROTECT(a = rep3(s, ns, na));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
static Rboolean any_nan_complex(SEXP x) {
const Rcomplex * xp = COMPLEX_RO(x);
const Rcomplex * const xe = xp + xlength(x);
for (; xp != xe; xp++) {
if (R_IsNaN((*xp).r) || R_IsNaN((*xp).i))
return TRUE;
}
return FALSE;
}
static Rboolean any_nan_double(SEXP x) {
const double * xp = REAL_RO(x);
const double * const xe = xp + xlength(x);
for (; xp != xe; xp++) {
if (R_IsNaN(*xp))
return TRUE;
}
return FALSE;
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names, X, XX, FUN;
R_xlen_t i, n;
PROTECT_INDEX px;
checkArity(op, args);
PROTECT_WITH_INDEX(X = CAR(args), &px);
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
tmp = eval(R_fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(3);
}
UNPROTECT(3); /* X, XX, ans */
return ans;
}
static msg_t check_bounds(SEXP x, SEXP lower, SEXP upper) {
double tmp;
tmp = asNumber(lower, "lower");
if (R_FINITE(tmp)) {
if (isReal(x)) {
const double *xp = REAL(x);
const double * const xend = xp + xlength(x);
for (; xp != xend; xp++) {
if (!ISNAN(*xp) && *xp < tmp)
return make_msg("All elements must be >= %g", tmp);
}
} else if (isInteger(x)) {
const int *xp = INTEGER(x);
const int * const xend = xp + xlength(x);
for (; xp != xend; xp++) {
if (*xp != NA_INTEGER && *xp < tmp)
return make_msg("All elements must be >= %g", tmp);
}
}
}
tmp = asNumber(upper, "upper");
if (R_FINITE(tmp)) {
if (isReal(x)) {
const double *xp = REAL(x);
const double * const xend = xp + xlength(x);
for (; xp != xend; xp++) {
if (!ISNAN(*xp) && *xp > tmp)
return make_msg("All elements must be <= %g", tmp);
}
} else if (isInteger(x)) {
const int *xp = INTEGER(x);
const int * const xend = xp + xlength(x);
for (; xp != xend; xp++) {
if (*xp != NA_INTEGER && *xp > tmp)
return make_msg("All elements must be <= %g", tmp);
}
}
}
return MSGT;
}
Rboolean all_nchar(SEXP x, R_xlen_t n, Rboolean skip_na) {
if (!isString(x)) {
SEXP xs = PROTECT(coerceVector(x, STRSXP));
Rboolean res = all_nchar(xs, n, skip_na);
UNPROTECT(1);
return res;
}
const R_xlen_t nx = xlength(x);
for (R_xlen_t i = 0; i < nx; i++) {
if (STRING_ELT(x, i) == NA_STRING) {
if (skip_na) continue;
return FALSE;
}
if (xlength(STRING_ELT(x, i)) < n) {
return FALSE;
}
}
return TRUE;
}
SEXP c_check_int(SEXP x, SEXP na_ok, SEXP lower, SEXP upper, SEXP tol) {
Rboolean is_na = is_scalar_na(x);
double dtol = asNumber(tol, "tol");
if (xlength(x) != 1 || (!is_na && !isIntegerish(x, dtol)))
return make_type_error(x, "single integerish value");
if (is_na) {
if (!asFlag(na_ok, "na.ok"))
return make_result("May not be NA");
}
assert(check_bounds(x, lower, upper));
return ScalarLogical(TRUE);
}
/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, s, t, call2;
int narm, has_na = 0;
/* initialize for behavior on empty vector
all(logical(0)) -> TRUE
any(logical(0)) -> FALSE
*/
Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;
PROTECT(args = fixup_NaRm(args));
PROTECT(call2 = duplicate(call));
SETCDR(call2, args);
if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
UNPROTECT(2);
return(ans);
}
ans = matchArgExact(R_NaRmSymbol, &args);
narm = asLogical(ans);
for (s = args; s != R_NilValue; s = CDR(s)) {
t = CAR(s);
/* Avoid memory waste from coercing empty inputs, and also
avoid warnings with empty lists coming from sapply */
if(xlength(t) == 0) continue;
/* coerceVector protects its argument so this actually works
just fine */
if (TYPEOF(t) != LGLSXP) {
/* Coercion of integers seems reasonably safe, but for
other types it is more often than not an error.
One exception is perhaps the result of lapply, but
then sapply was often what was intended. */
if(TYPEOF(t) != INTSXP)
warningcall(call,
_("coercing argument of type '%s' to logical"),
type2char(TYPEOF(t)));
t = coerceVector(t, LGLSXP);
}
val = checkValues(PRIMVAL(op), narm, LOGICAL(t), XLENGTH(t));
if (val != NA_LOGICAL) {
if ((PRIMVAL(op) == _OP_ANY && val)
|| (PRIMVAL(op) == _OP_ALL && !val)) {
has_na = 0;
break;
}
} else has_na = 1;
}
UNPROTECT(2);
return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
SEXP c_check_number(SEXP x, SEXP na_ok, SEXP lower, SEXP upper, SEXP finite) {
Rboolean is_na = is_scalar_na(x);
if (xlength(x) != 1 || (!is_na && !isStrictlyNumeric(x)))
return make_type_error(x, "number");
if (is_na) {
if (!asFlag(na_ok, "na.ok"))
return make_result("May not be NA");
return ScalarLogical(TRUE);
}
assert(check_vector_finite(x, finite));
assert(check_bounds(x, lower, upper));
return ScalarLogical(TRUE);
}
SEXP c_check_matrix(SEXP x, SEXP mode, SEXP any_missing, SEXP all_missing, SEXP min_rows, SEXP min_cols, SEXP rows, SEXP cols, SEXP row_names, SEXP col_names) {
if (!isMatrix(x))
return make_type_error(x, "matrix");
assert(check_storage(x, mode));
assert(check_matrix_dims(x, min_rows, min_cols, rows, cols));
if (!isNull(row_names) && xlength(x) > 0) {
SEXP nn = getAttrib(x, R_DimNamesSymbol);
if (!isNull(nn))
nn = VECTOR_ELT(nn, 0);
assert(check_names(nn, row_names, "Rows"));
}
if (!isNull(col_names) && xlength(x) > 0) {
SEXP nn = getAttrib(x, R_DimNamesSymbol);
if (!isNull(nn))
nn = VECTOR_ELT(nn, 1);
assert(check_names(nn, col_names, "Columns"));
}
assert(check_vector_missings(x, any_missing, all_missing));
return ScalarLogical(TRUE);
}
SEXP attribute_hidden do_seq_along(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
R_xlen_t len;
static SEXP length_op = NULL;
/* Store the .Primitive for 'length' for DispatchOrEval to use. */
if (length_op == NULL) {
SEXP R_lengthSymbol = install("length");
length_op = eval(R_lengthSymbol, R_BaseEnv);
if (TYPEOF(length_op) != BUILTINSXP) {
length_op = NULL;
error("'length' is not a BUILTIN");
}
R_PreserveObject(length_op);
}
checkArity(op, args);
check1argSymbol(args, call, R_AlongWithSymbol);
/* Try to dispatch to S3 or S4 methods for 'length'. For cases
where no methods are defined this is more efficient than an
unconditional callback to R */
if (isObject(CAR(args)) &&
DispatchOrEval(call, length_op, R_LengthCharSXP, args, rho, &ans, 0, 1)) {
len = asInteger(ans);
}
else
len = xlength(CAR(args));
#ifdef LONG_VECTOR_SUPPORT
if (len > INT_MAX) {
ans = allocVector(REALSXP, len);
double *p = REAL(ans);
for(R_xlen_t i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = (double) (i+1);
}
} else
#endif
{
ans = allocVector(INTSXP, len);
int *p = INTEGER(ans);
for(int i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = i+1;
}
}
return ans;
}
static inline Rboolean is_scalar_na(SEXP x) {
if (xlength(x) == 1) {
switch(TYPEOF(x)) {
case LGLSXP:
return (LOGICAL(x)[0] == NA_LOGICAL);
case INTSXP:
return (INTEGER(x)[0] == NA_INTEGER);
case REALSXP:
return ISNAN(REAL(x)[0]);
case STRSXP:
return (STRING_ELT(x, 0) == NA_STRING);
}
}
return FALSE;
}
SEXP c_check_count(SEXP x, SEXP na_ok, SEXP positive, SEXP tol) {
Rboolean is_na = is_scalar_na(x);
double dtol = asNumber(tol, "tol");
if (xlength(x) != 1 || (!is_na && !isIntegerish(x, dtol)))
return make_type_error(x, "count");
if (is_na) {
if (!asFlag(na_ok, "na.ok"))
return make_result("May not be NA");
} else {
const int pos = (int) asFlag(positive, "positive");
if (asInteger(x) < pos)
return make_result("Must be >= %i", pos);
}
return ScalarLogical(TRUE);
}
static Rboolean check_strict_names(SEXP x) {
const R_xlen_t nx = xlength(x);
const char *str;
for (R_xlen_t i = 0; i < nx; i++) {
str = CHAR(STRING_ELT(x, i));
while (*str == '.')
str++;
if (!isalpha(*str))
return FALSE;
for (; *str != '\0'; str++) {
if (!isalnum(*str) && *str != '.' && *str != '_')
return FALSE;
}
}
return TRUE;
}
SEXP
do_lzCompress (SEXP FROM, SEXP LEVEL)
{
char *buf;
int ret;
SEXP ans;
int level = *(INTEGER(LEVEL));
size_t input_size = (size_t) xlength(FROM);
size_t buffer_size = input_size*1.1 + 100;
if(TYPEOF(FROM) != RAWSXP) error("'from' must be raw or character");
buf = (char *) R_alloc(buffer_size, sizeof(char));
ret = lz4_compress((void *)RAW(FROM), input_size, (void *)buf, &buffer_size, level);
if(ret<0) error("internal error %d in lz4_compress",ret);
ans = allocVector(RAWSXP, buffer_size);
memcpy(RAW(ans), buf, buffer_size);
return ans;
}
SEXP count(SEXP x, SEXP idxs, SEXP value, SEXP what, SEXP naRm, SEXP hasNA) {
SEXP ans;
int narm, hasna, what2;
R_xlen_t nx;
/* Argument 'x' and 'dim': */
assertArgVector(x, (R_TYPE_LGL | R_TYPE_INT | R_TYPE_REAL), "x");
nx = xlength(x);
/* Argument 'value': */
if (length(value) != 1)
error("Argument 'value' must be a single value.");
if (!isNumeric(value))
error("Argument 'value' must be a numeric value.");
/* Argument 'what': */
what2 = asInteger(what);
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'hasNA': */
hasna = asLogicalNoNA(hasNA, "hasNA");
/* Argument 'idxs': */
R_xlen_t nrows, ncols = 1;
int rowsType, colsType = SUBSETTED_ALL;
void *crows = validateIndices(idxs, nx, 1, &nrows, &rowsType);
void *ccols = NULL;
/* R allocate a integer scalar */
PROTECT(ans = allocVector(INTSXP, 1));
if (isReal(x)) {
colCounts_Real[rowsType][colsType](REAL(x), nx, 1, crows, nrows, ccols, ncols, asReal(value), what2, narm, hasna, INTEGER(ans));
} else if (isInteger(x)) {
colCounts_Integer[rowsType][colsType](INTEGER(x), nx, 1, crows, nrows, ccols, ncols, asInteger(value), what2, narm, hasna, INTEGER(ans));
} else if (isLogical(x)) {
colCounts_Logical[rowsType][colsType](LOGICAL(x), nx, 1, crows, nrows, ccols, ncols, asLogical(value), what2, narm, hasna, INTEGER(ans));
}
UNPROTECT(1);
return(ans);
} // count()
SEXP xts_period_apply(SEXP _data, SEXP _index, SEXP _function, SEXP _env)
{
if (!isInteger(_index)) {
error("index must be integer");
}
int i;
R_xlen_t n = xlength(_index);
SEXP _result = PROTECT(allocVector(VECSXP, n));
SEXP _j = PROTECT(allocVector(INTSXP, ncols(_data)));
SEXP _drop = PROTECT(ScalarLogical(0));
int *index = INTEGER(_index);
for (i = 0; i < ncols(_data); i++)
INTEGER(_j)[i] = i + 1;
SEXP _idx0 = PROTECT(ScalarInteger(0));
SEXP _idx1 = PROTECT(ScalarInteger(0));
int *idx0 = INTEGER(_idx0);
int *idx1 = INTEGER(_idx1);
/* reprotect the subset object */
SEXP _xsubset;
PROTECT_INDEX px;
PROTECT_WITH_INDEX(_xsubset = R_NilValue, &px);
/* subset object name */
SEXP _subsym = install("_.*crazy*._.*name*._");
defineVar(_subsym, _xsubset, _env);
/* function call on subset */
SEXP _subcall = PROTECT(lang3(_function, _subsym, R_DotsSymbol));
int N = n - 1;
for (i = 0; i < N; i++) {
idx0[0] = index[i] + 1;
idx1[0] = index[i + 1];
REPROTECT(_xsubset = extract_col(_data, _j, _drop, _idx0, _idx1), px);
defineVar(_subsym, _xsubset, _env);
SET_VECTOR_ELT(_result, i, eval(_subcall, _env));
}
UNPROTECT(7);
return _result;
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises.
FUN must be unevaluated for use in e.g. bquote .
*/
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
PROTECT_INDEX px;
checkArity(op, args);
SEXP X, XX, FUN;
PROTECT_WITH_INDEX(X =CAR(args), &px);
XX = PROTECT(eval(CAR(args), rho));
R_xlen_t n = xlength(XX); // a vector, so will be valid.
FUN = CADR(args);
Rboolean realIndx = n > INT_MAX;
SEXP ans = PROTECT(allocVector(VECSXP, n));
SEXP names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP ind = PROTECT(allocVector(realIndx ? REALSXP : INTSXP, 1));
SEXP isym = install("i");
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
SEXP tmp = PROTECT(LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
SEXP R_fcall = PROTECT(LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
for(R_xlen_t i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
tmp = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(tmp)) tmp = lazy_duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(6);
return ans;
}
