SEXP dbarts_makeModelMatrixFromDataFrame(SEXP x, SEXP dropColumnsExpr)
{
int errorCode = 0;
SEXP result = R_NilValue;
SEXP dropPatternExpr = R_NilValue;
int protectCount = 0;
size_t numInputColumns = (size_t) rc_getLength(x);
size_t numOutputColumns = 0;
column_type columnTypes[numInputColumns];
getColumnTypes(x, columnTypes);
bool createDropPattern = false;
if (Rf_isLogical(dropColumnsExpr)) {
createDropPattern = LOGICAL(dropColumnsExpr)[0] == TRUE;
if (createDropPattern) {
dropPatternExpr = PROTECT(rc_newList(numInputColumns));
++protectCount;
if (rc_getNames(x) != R_NilValue) rc_setNames(dropPatternExpr, rc_getNames(x));
}
} else if (!createDropPattern && Rf_isVector(dropColumnsExpr)) {
dropPatternExpr = dropColumnsExpr;
}
countMatrixColumns(x, columnTypes, dropPatternExpr, createDropPattern, &numOutputColumns);
size_t numRows = getNumRowsForDataFrame(x);
if (numRows == 0) {
errorCode = EINVAL;
goto mkmm_cleanup;
}
result = PROTECT(rc_newReal(numRows * numOutputColumns));
++protectCount;
rc_setDims(result, (int) numRows, (int) numOutputColumns, -1);
SEXP dimNamesExpr = PROTECT(rc_newList(2));
rc_setDimNames(result, dimNamesExpr);
UNPROTECT(1);
SET_VECTOR_ELT(dimNamesExpr, 1, rc_newCharacter(numOutputColumns));
errorCode = createMatrix(x, numRows, result, columnTypes, dropPatternExpr);
mkmm_cleanup:
if (errorCode != 0) {
if (protectCount > 0) UNPROTECT(protectCount);
Rf_warning("error in makeModelMatrix: %s", strerror(errorCode));
return R_NilValue;
}
if (dropPatternExpr != NULL) Rf_setAttrib(result, Rf_install("drop"), dropPatternExpr);
if (protectCount > 0) UNPROTECT(protectCount);
return result;
}
int find_offset(SEXP x, SEXP index, int i) {
if (!Rf_isVector(index) || Rf_length(index) != 1)
Rf_errorcall(R_NilValue, "Index %i is not a length 1 vector", i + 1);
int n = Rf_length(x);
if (TYPEOF(index) == INTSXP) {
int val = INTEGER(index)[0];
if (val == NA_INTEGER)
return -1;
val--;
if (val < 0 || val >= n)
return -1;
return val;
} if (TYPEOF(index) == REALSXP) {
double val = REAL(index)[0];
if (!R_finite(val))
return -1;
val--;
if (val < 0 || val >= n)
return -1;
return val;
} else if (TYPEOF(index) == STRSXP) {
SEXP names = Rf_getAttrib(x, R_NamesSymbol);
if (names == R_NilValue) // vector doesn't have names
return -1;
if (STRING_ELT(index, 0) == NA_STRING)
return -1;
const char* val = Rf_translateCharUTF8(STRING_ELT(index, 0));
if (val[0] == '\0') // "" matches nothing
return -1;
for (int j = 0; j < Rf_length(names); ++j) {
if (STRING_ELT(names, j) == NA_STRING)
continue;
const char* names_j = Rf_translateCharUTF8(STRING_ELT(names, j));
if (strcmp(names_j, val) == 0)
return j;
}
return -1;
} else {
Rf_errorcall(R_NilValue,
"Don't know how to index with object of type %s at level %i",
Rf_type2char(TYPEOF(index)), i + 1
);
}
}
std::vector<bool> ToVectorBool(SEXP logical_vector){
if(!Rf_isVector(logical_vector)) {
report_error("ToVectorBool requires a logical vector argument.");
}
PROTECT(logical_vector = Rf_coerceVector(logical_vector, LGLSXP));
int n = Rf_length(logical_vector);
std::vector<bool> ans(n);
int *data = LOGICAL(logical_vector);
ans.assign(data, data + n);
UNPROTECT(1);
return ans;
}
SEXP extract_impl(SEXP x, SEXP index, SEXP missing) {
if (!Rf_isVector(x)) {
Rf_errorcall(R_NilValue, "`x` must be a vector (not a %s)",
Rf_type2char(TYPEOF(x)));
}
if (TYPEOF(index) != VECSXP) {
Rf_errorcall(R_NilValue, "`index` must be a vector (not a %s)",
Rf_type2char(TYPEOF(index)));
}
int n = Rf_length(index);
for (int i = 0; i < n; ++i) {
SEXP index_i = VECTOR_ELT(index, i);
int offset = find_offset(x, index_i, i);
if (offset < 0)
return missing;
switch(TYPEOF(x)) {
case NILSXP: return missing;
case LGLSXP: x = Rf_ScalarLogical(LOGICAL(x)[offset]); break;
case INTSXP: x = Rf_ScalarInteger(INTEGER(x)[offset]); break;
case REALSXP: x = Rf_ScalarReal(REAL(x)[offset]); break;
case STRSXP: x = Rf_ScalarString(STRING_ELT(x, offset)); break;
case VECSXP: x = VECTOR_ELT(x, offset); break;
default:
Rf_errorcall(R_NilValue,
"Don't know how to index object of type %s at level %i",
Rf_type2char(TYPEOF(x)), i + 1
);
}
}
return x;
}
SEXP transpose_impl(SEXP x, SEXP names_template) {
if (TYPEOF(x) != VECSXP)
Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x)));
int n = Rf_length(x);
if (n == 0) {
return Rf_allocVector(VECSXP, 0);
}
int has_template = !Rf_isNull(names_template);
SEXP x1 = VECTOR_ELT(x, 0);
if (!Rf_isVector(x1))
Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1)));
int m = has_template ? Rf_length(names_template) : Rf_length(x1);
// Create space for output
SEXP out = PROTECT(Rf_allocVector(VECSXP, m));
SEXP names1 = Rf_getAttrib(x, R_NamesSymbol);
for (int j = 0; j < m; ++j) {
SEXP xj = PROTECT(Rf_allocVector(VECSXP, n));
if (!Rf_isNull(names1)) {
Rf_setAttrib(xj, R_NamesSymbol, names1);
}
SET_VECTOR_ELT(out, j, xj);
UNPROTECT(1);
}
SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol);
if (!Rf_isNull(names2)) {
Rf_setAttrib(out, R_NamesSymbol, names2);
}
// Fill output
for (int i = 0; i < n; ++i) {
SEXP xi = VECTOR_ELT(x, i);
if (!Rf_isVector(xi))
Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1)));
// find mapping between names and index. Use -1 to indicate not found
SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol);
SEXP index;
if (!Rf_isNull(names2) && !Rf_isNull(names_i)) {
index = PROTECT(Rf_match(names_i, names2, 0));
// Rf_match returns 1-based index; convert to 0-based for C
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = INTEGER(index)[i] - 1;
}
} else {
index = PROTECT(Rf_allocVector(INTSXP, m));
int mi = Rf_length(xi);
if (m != mi) {
Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m);
}
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = (i < mi) ? i : -1;
}
}
int* pIndex = INTEGER(index);
for (int j = 0; j < m; ++j) {
int pos = pIndex[j];
if (pos == -1)
continue;
switch(TYPEOF(xi)) {
case LGLSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos]));
break;
case INTSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos]));
break;
case REALSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos]));
break;
case STRSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos)));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos));
break;
default:
Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi)));
}
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
