SEXP c_check_vector(SEXP x, SEXP strict, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isVector(x))
return make_type_error(x, "vector");
if (asFlag(strict, "strict")) {
SEXP attr = ATTRIB(x);
if ((length(attr) > 0 && (TAG(attr) != R_NamesSymbol)) || CDR(attr) != R_NilValue)
return make_type_error(x, "vector");
}
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
SEXP c_check_dataframe(SEXP x, SEXP any_missing, SEXP all_missing, SEXP min_rows, SEXP min_cols, SEXP rows, SEXP cols, SEXP row_names, SEXP col_names) {
if (!isFrame(x))
return make_type_error(x, "data.frame");
assert(check_matrix_dims(x, min_rows, min_cols, rows, cols));
if (!isNull(row_names)) {
SEXP nn = getAttrib(x, install("row.names"));
msg_t msg;
if (isInteger(nn)) {
nn = PROTECT(coerceVector(nn, STRSXP));
msg = check_names(nn, row_names, "Rows");
UNPROTECT(1);
} else {
msg = check_names(nn, row_names, "Rows");
}
if (!msg.ok)
return make_result(msg.msg);
}
if (!isNull(col_names))
assert(check_names(getAttrib(x, R_NamesSymbol), col_names, "Columns"));
if (!asFlag(any_missing, "any.missing") && any_missing_frame(x))
return make_result("Contains missing values");
if (!asFlag(all_missing, "all.missing") && all_missing_frame(x))
return make_result("Contains only missing values");
return ScalarLogical(TRUE);
}
SEXP c_check_array(SEXP x, SEXP mode, SEXP any_missing, SEXP d, SEXP min_d, SEXP max_d) {
if (!isArray(x))
return make_type_error(x, "array");
assert(check_storage(x, mode));
if (!asFlag(any_missing, "any.missing") && any_missing_atomic(x))
return make_result("Contains missing values");
R_len_t ndim = length(getAttrib(x, R_DimSymbol));
if (!isNull(d)) {
R_len_t di = asCount(d, "d");
if (ndim != di)
return make_result("Must be a %i-d array, but has dimension %i", di, ndim);
}
if (!isNull(min_d)) {
R_len_t di = asCount(min_d, "min.d");
if (ndim < di)
return make_result("Must have >=%i dimensions, but has dimension %i", di, ndim);
}
if (!isNull(max_d)) {
R_len_t di = asCount(max_d, "max.d");
if (ndim > di)
return make_result("Must have <=%i dimensions, but has dimension %i", di, ndim);
}
return ScalarLogical(TRUE);
}
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);
}
SEXP c_check_atomic_vector(SEXP x, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isVectorAtomic(x))
return make_type_error(x, "atomic vector");
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
SEXP c_check_integer(SEXP x, SEXP lower, SEXP upper, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isInteger(x) && !all_missing_atomic(x))
return make_type_error(x, "integer");
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_bounds(x, lower, upper));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
SEXP c_check_character(SEXP x, SEXP min_chars, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isString(x) && !all_missing_atomic(x))
return make_type_error(x, "character");
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_min_chars(x, min_chars));
assert(check_vector_unique(x, unique));
return ScalarLogical(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);
}
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);
}
// bit
Val bit(Val bitvec, Val index)
{
if (simple_bit_vector_p(bitvec))
{
return sbit(bitvec, index);
}
else if (bit_vector_p(bitvec))
{
const Vector* pRunner =
bitvec->Decode<Vector>();
if (cmp_xx(index, pRunner->m_total_size) >= 0)
{
error(Qvector_index_error,
Kvector, bitvec,
Kdatum, index );
}
for (;;)
{
index = add_xx(index, pRunner->m_offset);
Val datavec = pRunner->m_displaced_to;
if (simple_bit_vector_p(datavec))
{
return sbit(datavec, index);
}
if (! bit_vector_p(datavec))
{
error(make_type_error(bitvec, Qbit_vector));
}
pRunner = datavec->Decode<BitVector>();
} // for
} // if
error(make_type_error(bitvec, Qbit_vector));
} // bit
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);
}
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);
}
// Syntax:
// .replace-vector vector-1 vector-2 &optional start-1 end-1 start-2 end-2
// => vector-1
//
// Arguments and Values:
// vector-1 specialized vector or simple-vector.
// vector-2 vector of same type of vector-1
//
// For:
// bit-and, bit-andc1, ... bit-xor
// replace
//
Val replace_vector(Val v1, Val v2, Val s1, Val e1, Val s2, Val e2)
{
check_type(v1, data_vector);
Val classd = v1->Decode<Record>()->m_classd;
if (v2->Is<Record>() && v2->Decode<Record>()->m_classd != classd)
{
error(make_type_error(v2, type_of(v1)));
}
if (! fixnump(s1) || minusp_xx(s1) || cmp_xx(s1, length(v1)) > 0)
{
error(Qbounding_index_error, Kdatum, s1, Ksequence, v1);
}
if (nil == e1) e1 = length(v1);
if (! fixnump(e1) || cmp_xx(s1, e1) > 0 && cmp_xx(e1, length(v1)) > 0)
{
error(Qbounding_index_error,
Ksequence, v1,
Kstart, s1,
Kdatum, e1 );
}
if (! fixnump(s2) || minusp_xx(s2) || cmp_xx(s2, length(v2)) > 0)
{
error(Qbounding_index_error, Kdatum, s2, Ksequence, v2);
}
if (nil == e2) e2 = length(v1);
if (! fixnump(e2) || cmp_xx(s2, e2) > 0 && cmp_xx(e2, length(v2)) > 0)
{
error(Qbounding_index_error,
Ksequence, v2,
Kstart, s2,
Kdatum, e2 );
}
Int iS1 = Fixnum::Decode_(s1);
Int iS2 = Fixnum::Decode_(s2);
Int n1 = Fixnum::Decode_(e1) - iS1;
Int n2 = Fixnum::Decode_(e2) - iS2;
Int n = min(n1, n2);
if (0 == n) return v1;
void* pv1 = reinterpret_cast<void*>(v1->Decode<DataVector>() + 1);
void* pv2 = reinterpret_cast<void*>(v2->Decode<DataVector>() + 1);
switch (classd->Decode<ClassD>()->m_format_param->ToInt())
{
case Fixnum::One * 1:
bit_replace(v1, v2,
static_cast<uint>(iS1), static_cast<uint>(iS2),
static_cast<uint>(n) );
break;
case Fixnum::One * 8:
evcl_memmove(
reinterpret_cast<uint8*>(pv1) + iS1,
reinterpret_cast<uint8*>(pv2) + iS2,
n );
break;
case Fixnum::One * 16:
evcl_memmove(
reinterpret_cast<uint16*>(pv1) + iS1,
reinterpret_cast<uint16*>(pv2) + iS2,
n * 2 );
break;
case Fixnum::One * 32:
evcl_memmove(
reinterpret_cast<uint32*>(pv1) + iS1,
reinterpret_cast<uint32*>(pv2) + iS2,
n * 4 );
break;
case Fixnum::One * 64:
evcl_memmove(
reinterpret_cast<uint64*>(pv1) + iS1,
reinterpret_cast<uint64*>(pv2) + iS2,
n * 8 );
break;
case Fixnum::One * 128:
evcl_memmove(
reinterpret_cast<uint64*>(pv1) + iS1 * 2,
reinterpret_cast<uint64*>(pv2) + iS2 * 2,
n * 16 );
break;
default:
CAN_NOT_HAPPEN();
} // switch classd
return v1;
} // replace_vector
