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;
}
RcppDateVector::RcppDateVector(SEXP vec) {
int i;
if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
throw std::range_error("RcppDateVector: invalid numeric vector in constructor");
int len = Rf_length(vec);
if (len == 0)
throw std::range_error("RcppDateVector: null vector in constructor");
v.resize(len);
for (i = 0; i < len; i++)
v[i] = RcppDate( (int) REAL(vec)[i]);
}
bool RcppParams::getBoolValue(std::string name) {
std::map<std::string,int>::iterator iter = pmap.find(name);
if (iter == pmap.end()) {
std::string mesg = "RcppParams::getBoolValue: no such name: ";
throw std::range_error(mesg+name);
}
int posn = iter->second;
SEXP elt = VECTOR_ELT(_params,posn);
if (Rf_isLogical(elt))
return INTEGER(elt)[0];
else {
std::string mesg = "RcppParams::getBoolValue: invalid value for: ";
throw std::range_error(mesg+name);
}
return false; // never get here
}
char *nvimcom_browser_line(SEXP *x, const char *xname, const char *curenv, const char *prefix, char *p)
{
char xclass[64];
char newenv[512];
char curenvB[512];
char ebuf[64];
char pre[128];
char newpre[128];
int len;
const char *ename;
SEXP listNames, label, lablab, eexp, elmt = R_NilValue;
SEXP cmdSexp, cmdexpr, ans, cmdSexp2, cmdexpr2;
ParseStatus status, status2;
int er = 0;
char buf[128];
if(strlen(xname) > 64)
return p;
if(obbrbufzise < strlen(obbrbuf2) + 1024)
p = nvimcom_grow_obbrbuf();
p = nvimcom_strcat(p, prefix);
if(Rf_isLogical(*x)){
p = nvimcom_strcat(p, "%#");
strcpy(xclass, "logical");
} else if(Rf_isNumeric(*x)){
p = nvimcom_strcat(p, "{#");
strcpy(xclass, "numeric");
} else if(Rf_isFactor(*x)){
p = nvimcom_strcat(p, "'#");
strcpy(xclass, "factor");
} else if(Rf_isValidString(*x)){
p = nvimcom_strcat(p, "\"#");
strcpy(xclass, "character");
} else if(Rf_isFunction(*x)){
p = nvimcom_strcat(p, "(#");
strcpy(xclass, "function");
} else if(Rf_isFrame(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "data.frame");
} else if(Rf_isNewList(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "list");
} else if(Rf_isS4(*x)){
p = nvimcom_strcat(p, "<#");
strcpy(xclass, "s4");
} else if(TYPEOF(*x) == PROMSXP){
p = nvimcom_strcat(p, "&#");
strcpy(xclass, "lazy");
} else {
p = nvimcom_strcat(p, "=#");
strcpy(xclass, "other");
}
PROTECT(lablab = allocVector(STRSXP, 1));
SET_STRING_ELT(lablab, 0, mkChar("label"));
PROTECT(label = getAttrib(*x, lablab));
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\t");
if(length(label) > 0){
if(Rf_isValidString(label)){
snprintf(buf, 127, "%s", CHAR(STRING_ELT(label, 0)));
p = nvimcom_strcat(p, buf);
} else {
if(labelerr)
p = nvimcom_strcat(p, "Error: label isn't \"character\".");
}
}
p = nvimcom_strcat(p, "\n");
UNPROTECT(2);
if(strcmp(xclass, "list") == 0 || strcmp(xclass, "data.frame") == 0 || strcmp(xclass, "s4") == 0){
strncpy(curenvB, curenv, 500);
if(xname[0] == '[' && xname[1] == '['){
curenvB[strlen(curenvB) - 1] = 0;
}
if(strcmp(xclass, "s4") == 0)
snprintf(newenv, 500, "%s%s@", curenvB, xname);
else
snprintf(newenv, 500, "%s%s$", curenvB, xname);
if((nvimcom_get_list_status(newenv, xclass) == 1)){
len = strlen(prefix);
if(nvimcom_is_utf8){
int j = 0, i = 0;
while(i < len){
if(prefix[i] == '\xe2'){
i += 3;
if(prefix[i-1] == '\x80' || prefix[i-1] == '\x94'){
pre[j] = ' '; j++;
} else {
pre[j] = '\xe2'; j++;
pre[j] = '\x94'; j++;
pre[j] = '\x82'; j++;
}
} else {
pre[j] = prefix[i];
i++, j++;
}
}
pre[j] = 0;
} else {
for(int i = 0; i < len; i++){
if(prefix[i] == '-' || prefix[i] == '`')
pre[i] = ' ';
else
pre[i] = prefix[i];
}
pre[len] = 0;
}
sprintf(newpre, "%s%s", pre, strT);
if(strcmp(xclass, "s4") == 0){
snprintf(buf, 127, "slotNames(%s%s)", curenvB, xname);
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(buf));
PROTECT(cmdexpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid value in slotNames(");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, ")\n");
} else {
PROTECT(ans = R_tryEval(VECTOR_ELT(cmdexpr, 0), R_GlobalEnv, &er));
if(er){
p = nvimcom_strcat(p, "nvimcom error: ");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\n");
} else {
len = length(ans);
if(len > 0){
int len1 = len - 1;
for(int i = 0; i < len; i++){
ename = CHAR(STRING_ELT(ans, i));
snprintf(buf, 127, "%s%s@%s", curenvB, xname, ename);
PROTECT(cmdSexp2 = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp2, 0, mkChar(buf));
PROTECT(cmdexpr2 = R_ParseVector(cmdSexp2, -1, &status2, R_NilValue));
if (status2 != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid code \"");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "@");
p = nvimcom_strcat(p, ename);
p = nvimcom_strcat(p, "\"\n");
} else {
PROTECT(elmt = R_tryEval(VECTOR_ELT(cmdexpr2, 0), R_GlobalEnv, &er));
if(i == len1)
sprintf(newpre, "%s%s", pre, strL);
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
}
UNPROTECT(1);
}
UNPROTECT(2);
} else {
PROTECT(listNames = getAttrib(*x, R_NamesSymbol));
len = length(listNames);
if(len == 0){ /* Empty list? */
int len1 = length(*x);
if(len1 > 0){ /* List without names */
len1 -= 1;
for(int i = 0; i < len1; i++){
sprintf(ebuf, "[[%d]]", i + 1);
elmt = VECTOR_ELT(*x, i);
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
}
sprintf(newpre, "%s%s", pre, strL);
sprintf(ebuf, "[[%d]]", len1 + 1);
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
UNPROTECT(1);
}
} else { /* Named list */
len -= 1;
for(int i = 0; i < len; i++){
PROTECT(eexp = STRING_ELT(listNames, i));
ename = CHAR(eexp);
UNPROTECT(1);
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", i + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, i));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
sprintf(newpre, "%s%s", pre, strL);
ename = CHAR(STRING_ELT(listNames, len));
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", len + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(1); /* listNames */
}
}
}
return p;
}
