// 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; }