// Sets the names attribute of list to a character vector equivalent
// to 'names'.
SEXP setListNames(SEXP list, const std::vector<std::string> &names) {
int n = Rf_length(list);
if(n != names.size()){
report_error("'list' and 'names' are not the same size in setlistNames");
}
SEXP list_names;
PROTECT(list_names = Rf_allocVector(STRSXP, n));
for(int i = 0; i < n; ++i) {
SET_STRING_ELT(list_names, i, Rf_mkChar(names[i].c_str()));
}
Rf_namesgets(list, list_names);
UNPROTECT(1);
return list;
}
static SEXP
rpf_dTheta_wrapper(SEXP r_spec, SEXP r_param, SEXP r_where, SEXP r_dir)
{
if (Rf_length(r_spec) < RPF_ISpecCount)
Rf_error("Item spec must be of length %d, not %d", RPF_ISpecCount, Rf_length(r_spec));
double *spec = REAL(r_spec);
int id = spec[RPF_ISpecID];
if (id < 0 || id >= Glibrpf_numModels)
Rf_error("Item model %d out of range", id);
int numSpec = (*Glibrpf_model[id].numSpec)(spec);
if (Rf_length(r_spec) < numSpec)
Rf_error("Item spec must be of length %d, not %d", numSpec, Rf_length(r_spec));
int numParam = (*Glibrpf_model[id].numParam)(spec);
if (Rf_length(r_param) < numParam)
Rf_error("Item has %d parameters, only %d given", numParam, Rf_length(r_param));
int dims = spec[RPF_ISpecDims];
if (dims == 0) Rf_error("Item has no factors");
if (Rf_length(r_dir) != dims)
Rf_error("Item has %d dimensions, but dir is of length %d",
dims, Rf_length(r_dir));
if (Rf_length(r_where) != dims)
Rf_error("Item has %d dimensions, but where is of length %d",
dims, Rf_length(r_where));
SEXP ret, names;
Rf_protect(ret = Rf_allocVector(VECSXP, 2));
Rf_protect(names = Rf_allocVector(STRSXP, 2));
int outcomes = spec[RPF_ISpecOutcomes];
SEXP grad, hess;
Rf_protect(grad = Rf_allocVector(REALSXP, outcomes));
Rf_protect(hess = Rf_allocVector(REALSXP, outcomes));
memset(REAL(grad), 0, sizeof(double) * outcomes);
memset(REAL(hess), 0, sizeof(double) * outcomes);
(*Glibrpf_model[id].dTheta)(spec, REAL(r_param), REAL(r_where), REAL(r_dir),
REAL(grad), REAL(hess));
SET_VECTOR_ELT(ret, 0, grad);
SET_VECTOR_ELT(ret, 1, hess);
SET_STRING_ELT(names, 0, Rf_mkChar("gradient"));
SET_STRING_ELT(names, 1, Rf_mkChar("hessian"));
Rf_namesgets(ret, names);
UNPROTECT(4);
return ret;
}
SEXP MxRList::asR()
{
// detect duplicate keys? TODO
SEXP names, ans;
int len = size();
Rf_protect(names = Rf_allocVector(STRSXP, len));
Rf_protect(ans = Rf_allocVector(VECSXP, len));
for (int lx=0; lx < len; ++lx) {
const char *p1 = (*this)[lx].first;
SEXP p2 = (*this)[lx].second;
if (!p1 || !p2) Rf_error("Attempt to return NULL pointer to R");
SET_STRING_ELT(names, lx, Rf_mkChar(p1));
SET_VECTOR_ELT(ans, lx, p2);
}
Rf_namesgets(ans, names);
return ans;
}
SEXP appendListElement(SEXP list, SEXP new_element, const std::string &name){
int n = Rf_length(list);
SEXP ans;
PROTECT(ans = Rf_allocVector(VECSXP, n+1));
for(int i = 0; i < n; ++i){
SET_VECTOR_ELT(ans, i, VECTOR_ELT(list, i));
}
SET_VECTOR_ELT(ans, n, new_element);
SEXP old_list_names = Rf_getAttrib(list, R_NamesSymbol);
SEXP list_names;
PROTECT(list_names = Rf_allocVector(STRSXP, n+1));
if(!Rf_isNull(old_list_names)){
for(int i = 0; i < n; ++i){
SET_STRING_ELT(list_names, i, STRING_ELT(old_list_names, i));
}
}
SET_STRING_ELT(list_names, n, Rf_mkChar(name.c_str()));
Rf_namesgets(ans, list_names);
UNPROTECT(2);
return ans;
}
static SEXP
rpf_paramInfo_wrapper(SEXP r_spec, SEXP r_paramNum)
{
if (Rf_length(r_spec) < RPF_ISpecCount)
Rf_error("Item spec must be of length %d, not %d", RPF_ISpecCount, Rf_length(r_spec));
double *spec = REAL(r_spec);
int id = spec[RPF_ISpecID];
if (id < 0 || id >= Glibrpf_numModels)
Rf_error("Item model %d out of range", id);
int pnum = Rf_asInteger(r_paramNum);
int numParam = (*Glibrpf_model[id].numParam)(spec);
if (pnum < 0 || pnum >= numParam) Rf_error("Item model %d has %d parameters", id, numParam);
const char *type;
double upper, lower;
(*Glibrpf_model[id].paramInfo)(spec, pnum, &type, &upper, &lower);
int len = 3;
SEXP names, ans;
Rf_protect(names = Rf_allocVector(STRSXP, len));
Rf_protect(ans = Rf_allocVector(VECSXP, len));
int lx = 0;
SET_STRING_ELT(names, lx, Rf_mkChar("type"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarString(Rf_mkChar(type)));
SET_STRING_ELT(names, ++lx, Rf_mkChar("upper"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(upper)? upper : NA_REAL));
SET_STRING_ELT(names, ++lx, Rf_mkChar("lower"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(lower)? lower : NA_REAL));
Rf_namesgets(ans, names);
UNPROTECT(2);
return ans;
}
