cppbugs::MCMCObject* createMCMC(SEXP x_, vpArmaMapT& armaMap) {
SEXP distributed_sexp;
distributed_sexp = Rf_getAttrib(x_,Rf_install("distributed"));
SEXP class_sexp = Rf_getAttrib(x_,R_ClassSymbol);
if(class_sexp == R_NilValue || TYPEOF(class_sexp) != STRSXP || CHAR(STRING_ELT(class_sexp,0))==NULL || strcmp(CHAR(STRING_ELT(class_sexp,0)),"mcmc.object")) {
throw std::logic_error("ERROR: class attribute not defined or not equal to 'mcmc.object'.");
}
if(distributed_sexp == R_NilValue) {
throw std::logic_error("ERROR: 'distributed' attribute not defined. Is this an mcmc.object?");
}
if(armaMap.count(rawAddress(x_))==0) {
throw std::logic_error("ArmaContext not found (object should be mapped before call to createMCMC).");
}
distT distributed = matchDistibution(std::string(CHAR(STRING_ELT(distributed_sexp,0))));
cppbugs::MCMCObject* ans;
switch(distributed) {
// deterministic types
case deterministicT:
ans = createDeterministic(x_,armaMap);
break;
case linearDeterministicT:
ans = createLinearDeterministic(x_,armaMap);
break;
case linearGroupedDeterministicT:
ans = createLinearGroupedDeterministic(x_,armaMap);
break;
case logisticDeterministicT:
ans = createLogisticDeterministic(x_,armaMap);
break;
// continuous types
case normalDistT:
ans = createNormal(x_,armaMap);
break;
case uniformDistT:
ans = createUniform(x_,armaMap);
break;
case gammaDistT:
ans = createGamma(x_,armaMap);
break;
case betaDistT:
ans = createBeta(x_,armaMap);
break;
// discrete types
case bernoulliDistT:
ans = createBernoulli(x_,armaMap);
break;
case binomialDistT:
ans = createBinomial(x_,armaMap);
break;
default:
// not implemented
ans = NULL;
throw std::logic_error("ERROR: distribution not supported yet.");
}
return ans;
}
size_t getColnamesSize() const {
if (Rf_getAttrib(Robject, R_DimNamesSymbol) != R_NilValue &&
VECTOR_ELT(Rf_getAttrib(Robject, R_DimNamesSymbol), 1) != R_NilValue) {
return Rf_length(VECTOR_ELT(Rf_getAttrib(Robject, R_DimNamesSymbol), 1));
}
return 0;
}
/** Get the symmetric closure of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_closure_symmetric(SEXP x)
{
x = prepare_arg_logical_square_matrix(x, "R");
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
SEXP y = Rf_allocVector(LGLSXP, n*n);
int* yp = INTEGER(y);
Rf_setAttrib(y, R_DimSymbol, dim);
Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames
for (R_len_t i=0; i<n*n; ++i) {
if (xp[i] == NA_LOGICAL)
Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
yp[i] = xp[i];
}
for (R_len_t i=0; i<n-1; ++i) {
for (R_len_t j=i+1; j<n; ++j) {
if (yp[i+n*j] && !yp[j+n*i])
yp[j+n*i] = TRUE;
else if (yp[j+n*i] && !yp[i+n*j])
yp[i+n*j] = TRUE;
}
}
return y;
}
SEXP check_grouped(RObject data) {
static SEXP groups_symbol = Rf_install("groups");
static SEXP vars_symbol = Rf_install("vars");
// compat with old style grouped data frames
SEXP vars = Rf_getAttrib(data, vars_symbol);
if (!Rf_isNull(vars)) {
DataFrame groups = build_index_cpp(data, SymbolVector(vars));
data.attr("groups") = groups;
}
// get the groups attribute and check for consistency
SEXP groups = Rf_getAttrib(data, groups_symbol);
// groups must be a data frame
if (!is<DataFrame>(groups)) {
bad_arg(".data", "is a corrupt grouped_df, the `\"groups\"` attribute must be a data frame");
}
// it must have at least 1 column
int nc = Rf_length(groups);
if (nc <= 1) {
bad_arg(".data", "is a corrupt grouped_df, the `\"groups\"` attribute must have at least two columns");
}
// the last column must be a list and called `.rows`
SEXP names = Rf_getAttrib(groups, R_NamesSymbol);
SEXP last = VECTOR_ELT(groups, nc - 1);
static String rows = ".rows";
if (TYPEOF(last) != VECSXP || STRING_ELT(names, nc - 1) != rows) {
bad_arg(".data", "is a corrupt grouped_df, the `\"groups\"` attribute must have a list column named `.rows` as last column");
}
return data ;
}
/** Get the transitive closure of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_closure_transitive(SEXP x)
{
x = prepare_arg_logical_square_matrix(x, "R");
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
SEXP y = Rf_allocVector(LGLSXP, n*n);
int* yp = INTEGER(y);
Rf_setAttrib(y, R_DimSymbol, dim);
Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames
for (R_len_t i=0; i<n*n; ++i) {
if (xp[i] == NA_LOGICAL)
Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
yp[i] = xp[i];
}
for (R_len_t k=0; k<n; ++k) { // Warshall's algorithm
for (R_len_t i=0; i<n; ++i) {
for (R_len_t j=0; j<n; ++j) {
yp[i+n*j] = (yp[i+n*j] || (yp[i+n*k] && yp[k+n*j]));
}
}
}
return y;
}
std::vector<std::string> getColnames() const {
std::vector<std::string> ans;
if (Rf_getAttrib(Robject, R_DimNamesSymbol) != R_NilValue &&
VECTOR_ELT(Rf_getAttrib(Robject, R_DimNamesSymbol), 1) != R_NilValue) {
SEXP cnames = VECTOR_ELT(Rf_getAttrib(Robject, R_DimNamesSymbol), 1);
for (R_len_t i = 0; i < Rf_length(cnames); ++i) { ans.push_back(CHAR(STRING_ELT(cnames, i))); }
}
return ans;
}
cppbugs::MCMCObject* createLinearGroupedDeterministic(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP X_ = Rf_getAttrib(x_,Rf_install("X"));
SEXP b_ = Rf_getAttrib(x_,Rf_install("b"));
SEXP group_ = Rf_getAttrib(x_,Rf_install("group"));
if(x_ == R_NilValue || env_ == R_NilValue || X_ == R_NilValue || b_ == R_NilValue || group_ == R_NilValue) {
throw std::logic_error("ERROR: createLinearDeterministic, missing or null argument.");
}
// force substitutions
X_ = forceEval(X_, env_, eval_limit);
b_ = forceEval(b_, env_, eval_limit);
group_ = forceEval(group_, env_, eval_limit);
// map to arma types
ArmaContext* X_arma = mapOrFetch(X_, armaMap);
ArmaContext* b_arma = mapOrFetch(b_, armaMap);
ArmaContext* group_arma = mapOrFetch(group_, armaMap);
// little x
if(x_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, x must be a real valued matrix.");
}
// big X
if(X_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, X must be a matrix.");
}
// b -- coefs vector
if(b_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, b must be a real valued matrix.");
}
// group -- multilevel group
if(group_arma->getArmaType() != ivecT) {
throw std::logic_error("ERROR: createLinearGroupedDeterministic, group must be an integer vector.");
}
switch(X_arma->getArmaType()) {
case matT:
p = new cppbugs::LinearGroupedDeterministic<arma::mat>(x_arma->getMat(),X_arma->getMat(),b_arma->getMat(),group_arma->getiVec());
break;
case imatT:
p = new cppbugs::LinearGroupedDeterministic<arma::imat>(x_arma->getMat(),X_arma->getiMat(),b_arma->getMat(),group_arma->getiVec());
break;
default:
throw std::logic_error("ERROR: createLinearGroupedDeterministic, combination of arguments not supported.");
}
return p;
}
cppbugs::MCMCObject* createNormal(SEXP x_,vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP mu_ = Rf_getAttrib(x_,Rf_install("mu"));
SEXP tau_ = Rf_getAttrib(x_,Rf_install("tau"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
//Rprintf("typeof mu: %d\n",TYPEOF(mu_));
if(x_ == R_NilValue || env_ == R_NilValue || mu_ == R_NilValue || tau_ == R_NilValue || observed_ == R_NilValue) {
throw std::logic_error("ERROR: createNormal, missing or null argument.");
}
// force substitutions
mu_ = forceEval(mu_, env_, eval_limit);
tau_ = forceEval(tau_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* mu_arma = mapOrFetch(mu_, armaMap);
ArmaContext* tau_arma = mapOrFetch(tau_, armaMap);
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignNormalLogp<cppbugs::ObservedNormal>(x_arma->getDouble(),mu_arma,tau_arma);
} else {
p = assignNormalLogp<cppbugs::Normal>(x_arma->getDouble(),mu_arma,tau_arma);
}
break;
case vecT:
if(observed) {
p = assignNormalLogp<cppbugs::ObservedNormal>(x_arma->getVec(),mu_arma,tau_arma);
} else {
p = assignNormalLogp<cppbugs::Normal>(x_arma->getVec(),mu_arma,tau_arma);
}
break;
case matT:
if(observed) {
p = assignNormalLogp<cppbugs::ObservedNormal>(x_arma->getMat(),mu_arma,tau_arma);
} else {
p = assignNormalLogp<cppbugs::Normal>(x_arma->getMat(),mu_arma,tau_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: normal must be a continuous variable type (double, vec, or mat).");
}
return p;
}
cppbugs::MCMCObject* createBernoulli(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP p_ = Rf_getAttrib(x_,Rf_install("p"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || p_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
p_ = forceEval(p_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* p_arma = mapOrFetch(p_, armaMap);
if(p_arma->getArmaType() != doubleT && p_arma->getArmaType() != vecT && p_arma->getArmaType() != matT) {
throw std::logic_error("ERROR: createBernoulli, p must be a continuous variable.");
}
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignBernoulliLogp<cppbugs::ObservedBernoulli>(x_arma->getDouble(),p_arma);
} else {
p = assignBernoulliLogp<cppbugs::Bernoulli>(x_arma->getDouble(),p_arma);
}
break;
case vecT:
if(observed) {
p = assignBernoulliLogp<cppbugs::ObservedBernoulli>(x_arma->getVec(),p_arma);
} else {
p = assignBernoulliLogp<cppbugs::Bernoulli>(x_arma->getVec(),p_arma);
}
break;
case matT:
if(observed) {
p = assignBernoulliLogp<cppbugs::ObservedBernoulli>(x_arma->getMat(),p_arma);
} else {
p = assignBernoulliLogp<cppbugs::Bernoulli>(x_arma->getMat(),p_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: Bernoulli must be a discrete valued continuous variable type (double, vec, or mat). This is due to an issue in armadillo.");
}
return p;
}
cppbugs::MCMCObject* createGamma(SEXP x_, vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP alpha_ = Rf_getAttrib(x_,Rf_install("alpha"));
SEXP beta_ = Rf_getAttrib(x_,Rf_install("beta"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || alpha_ == R_NilValue || beta_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
alpha_ = forceEval(alpha_, env_, eval_limit);
beta_ = forceEval(beta_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* alpha_arma = mapOrFetch(alpha_, armaMap);
ArmaContext* beta_arma = mapOrFetch(beta_, armaMap);
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignGammaLogp<cppbugs::ObservedGamma>(x_arma->getDouble(),alpha_arma,beta_arma);
} else {
p = assignGammaLogp<cppbugs::Gamma>(x_arma->getDouble(),alpha_arma,beta_arma);
}
break;
case vecT:
if(observed) {
p = assignGammaLogp<cppbugs::ObservedGamma>(x_arma->getVec(),alpha_arma,beta_arma);
} else {
p = assignGammaLogp<cppbugs::Gamma>(x_arma->getVec(),alpha_arma,beta_arma);
}
break;
case matT:
if(observed) {
p = assignGammaLogp<cppbugs::ObservedGamma>(x_arma->getMat(),alpha_arma,beta_arma);
} else {
p = assignGammaLogp<cppbugs::Gamma>(x_arma->getMat(),alpha_arma,beta_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: gamma must be a continuous variable type (double, vec, or mat).");
}
return p;
}
cppbugs::MCMCObject* createUniform(SEXP x_,vpArmaMapT& armaMap) {
const int eval_limit = 10;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
SEXP lower_ = Rf_getAttrib(x_,Rf_install("lower"));
SEXP upper_ = Rf_getAttrib(x_,Rf_install("upper"));
SEXP observed_ = Rf_getAttrib(x_,Rf_install("observed"));
if(x_ == R_NilValue || env_ == R_NilValue || lower_ == R_NilValue || upper_ == R_NilValue || observed_ == R_NilValue) {
REprintf("ERROR: missing argument.");
return NULL;
}
// force substitutions
lower_ = forceEval(lower_, env_, eval_limit);
upper_ = forceEval(upper_, env_, eval_limit);
bool observed = Rcpp::as<bool>(observed_);
// map to arma types
ArmaContext* lower_arma = mapOrFetch(lower_, armaMap);
ArmaContext* upper_arma = mapOrFetch(upper_, armaMap);
switch(x_arma->getArmaType()) {
case doubleT:
if(observed) {
p = assignUniformLogp<cppbugs::ObservedUniform>(x_arma->getDouble(),lower_arma,upper_arma);
} else {
p = assignUniformLogp<cppbugs::Uniform>(x_arma->getDouble(),lower_arma,upper_arma);
}
break;
case vecT:
if(observed) {
p = assignUniformLogp<cppbugs::ObservedUniform>(x_arma->getVec(),lower_arma,upper_arma);
} else {
p = assignUniformLogp<cppbugs::Uniform>(x_arma->getVec(),lower_arma,upper_arma);
}
break;
case matT:
if(observed) {
p = assignUniformLogp<cppbugs::ObservedUniform>(x_arma->getMat(),lower_arma,upper_arma);
} else {
p = assignUniformLogp<cppbugs::Uniform>(x_arma->getMat(),lower_arma,upper_arma);
}
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: uniform must be a continuous variable type (double, vec, or mat).");
}
return p;
}
SymbolVector GroupedDataFrame::group_vars(SEXP x) {
check_grouped(x);
static SEXP groups_symbol = Rf_install("groups");
SEXP groups = Rf_getAttrib(x, groups_symbol);
int n = Rf_length(groups) - 1;
CharacterVector vars = Rf_getAttrib(groups, R_NamesSymbol);
vars.erase(n);
return SymbolVector(vars);
}
// SEXP constructor assumes an existing fts object
// throw if fts class is missing or index is missing
BackendBase(const SEXP x) : Robject(PROTECT(x)) {
if (Rf_getAttrib(Robject, R_ClassSymbol) == R_NilValue) {
throw std::logic_error("BackendBase(const SEXP x): Object has no classname.");
}
if (strcmp(CHAR(STRING_ELT(Rf_getAttrib(Robject, R_ClassSymbol), 0)), "fts") != 0) {
throw std::logic_error("BackendBase(const SEXP x): not an fts object.");
}
if (Rf_getAttrib(Robject, Rf_install("index")) == R_NilValue) {
throw std::logic_error("BackendBase(const SEXP x): Object has no index.");
}
}
cppbugs::MCMCObject* createDeterministic(SEXP x_, vpArmaMapT& armaMap) {
SEXP args_;
cppbugs::MCMCObject* p;
ArmaContext* x_arma = armaMap[rawAddress(x_)];
// function should be in position 1 (excluding fun/call name)
SEXP fun_ = Rf_getAttrib(x_,Rf_install("update.method"));
if(fun_ == R_NilValue || (TYPEOF(fun_) != CLOSXP && TYPEOF(fun_) != BCODESXP)) {
throw std::logic_error("ERROR: update method must be a function.");
}
SEXP env_ = Rf_getAttrib(x_,Rf_install("env"));
if(env_ == R_NilValue || TYPEOF(env_) != ENVSXP) {
throw std::logic_error("ERROR: bad environment passed to deterministic.");
}
SEXP call_ = Rf_getAttrib(x_,Rf_install("call"));
if(TYPEOF(call_) != LANGSXP) {
throw std::logic_error("ERROR: function arguments not LANGSXP.");
}
if(Rf_length(call_) <= 2) {
throw std::logic_error("ERROR: function must have at least one argument.");
}
// advance by 2
args_ = CDR(call_);
args_ = CDR(args_);
// map to arma types
try {
switch(x_arma->getArmaType()) {
case doubleT:
p = new cppbugs::RDeterministic<double>(x_arma->getDouble(),fun_,args_,env_);
break;
case vecT:
p = new cppbugs::RDeterministic<arma::vec>(x_arma->getVec(),fun_,args_,env_);
break;
case matT:
p = new cppbugs::RDeterministic<arma::mat>(x_arma->getMat(),fun_,args_,env_);
break;
case intT:
case ivecT:
case imatT:
default:
throw std::logic_error("ERROR: deterministic must be a continuous variable type (double, vec, or mat) for now (under development).");
}
} catch(std::logic_error &e) {
REprintf("%s\n",e.what());
return NULL;
}
return p;
}
SEXP vflatten_impl(SEXP x, SEXP type_) {
if (TYPEOF(x) != VECSXP) {
stop_bad_type(x, "a list", NULL, ".x");
}
int m = Rf_length(x);
SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
// Determine output size and type
int n = 0;
int has_names = 0;
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
n += Rf_length(x_j);
if (!has_names && !Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) {
has_names = 1;
}
}
SEXP out = PROTECT(Rf_allocVector(type, n));
SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
if (has_names)
Rf_setAttrib(out, R_NamesSymbol, names);
UNPROTECT(1);
int i = 0;
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
int n_j = Rf_length(x_j);
SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol));
int has_names_j = !Rf_isNull(names_j);
for (int k = 0; k < n_j; ++k, ++i) {
set_vector_value(out, i, x_j, k);
if (has_names)
SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar(""));
if (i % 1024 == 0)
R_CheckUserInterrupt();
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
/** Read settings flags from a list
*
* may call Rf_error
*
* @param opts_fixed list
* @param allow_overlap
* @return flags
*
* @version 0.4-1 (Marek Gagolewski, 2014-12-07)
*
* @version 0.4-1 (Marek Gagolewski, 2014-12-08)
* add `overlap` option
*/
uint32_t StriContainerByteSearch::getByteSearchFlags(SEXP opts_fixed, bool allow_overlap)
{
uint32_t flags = 0;
if (!isNull(opts_fixed) && !Rf_isVectorList(opts_fixed))
Rf_error(MSG__ARG_EXPECTED_LIST, "opts_fixed"); // error() call allowed here
R_len_t narg = isNull(opts_fixed)?0:LENGTH(opts_fixed);
if (narg > 0) {
SEXP names = Rf_getAttrib(opts_fixed, R_NamesSymbol);
if (names == R_NilValue || LENGTH(names) != narg)
Rf_error(MSG__FIXED_CONFIG_FAILED); // error() call allowed here
for (R_len_t i=0; i<narg; ++i) {
if (STRING_ELT(names, i) == NA_STRING)
Rf_error(MSG__FIXED_CONFIG_FAILED); // error() call allowed here
const char* curname = CHAR(STRING_ELT(names, i));
if (!strcmp(curname, "case_insensitive")) {
bool val = stri__prepare_arg_logical_1_notNA(VECTOR_ELT(opts_fixed, i), "case_insensitive");
if (val) flags |= BYTESEARCH_CASE_INSENSITIVE;
} else if (!strcmp(curname, "overlap") && allow_overlap) {
bool val = stri__prepare_arg_logical_1_notNA(VECTOR_ELT(opts_fixed, i), "overlap");
if (val) flags |= BYTESEARCH_OVERLAP;
} else {
Rf_warning(MSG__INCORRECT_FIXED_OPTION, curname);
}
}
}
return flags;
}
void ifaGroup::verifyFactorNames(SEXP mat, const char *matName)
{
static const char *dimname[] = { "row", "col" };
SEXP dimnames;
Rf_protect(dimnames = Rf_getAttrib(mat, R_DimNamesSymbol));
if (!Rf_isNull(dimnames) && Rf_length(dimnames) == 2) {
for (int dx=0; dx < 2; ++dx) {
SEXP names;
Rf_protect(names = VECTOR_ELT(dimnames, dx));
if (!Rf_length(names)) continue;
if (int(factorNames.size()) != Rf_length(names)) {
mxThrow("%s %snames must be length %d",
matName, dimname[dx], (int) factorNames.size());
}
int nlen = Rf_length(names);
for (int nx=0; nx < nlen; ++nx) {
const char *name = CHAR(STRING_ELT(names, nx));
if (strEQ(factorNames[nx].c_str(), name)) continue;
mxThrow("%s %snames[%d] is '%s', does not match factor name '%s'",
matName, dimname[dx], 1+nx, name, factorNames[nx].c_str());
}
}
}
}
SEXP get_function_from_env_attrib(SEXP x, SEXP attribSym, SEXP nameSym) {
SEXP methods_env = Rf_getAttrib(x, attribSym);
if (isEnvironment(methods_env)) {
return Rf_findVarInFrame(methods_env, nameSym);
}
return R_NilValue;
}
SEXP subset_R8(SEXP x, SEXP name) {
// Look in x (an environment) for the object
SEXP nameSym = Rf_install(CHAR(STRING_ELT(name, 0)));
SEXP foundVar = Rf_findVarInFrame(x, nameSym);
if (foundVar != R_UnboundValue) {
return foundVar;
}
// if not found in x, look in methods
SEXP fun = get_function_from_env_attrib(x, Rf_install("methods"), nameSym);
// If not found in methods, search in methods2. This is present only for
// storing private methods in a superclass.
if (!isFunction(fun)) {
fun = get_function_from_env_attrib(x, Rf_install("methods2"), nameSym);
}
if (!isFunction(fun)) {
return R_NilValue;
}
// Make a copy of the function, with a new environment
SEXP fun2 = PROTECT(duplicate(fun));
SEXP eval_env = Rf_getAttrib(x, Rf_install("eval_env"));
if (!isEnvironment(eval_env)) {
UNPROTECT(1);
return R_NilValue;
}
SET_CLOENV(fun2, eval_env);
UNPROTECT(1);
return fun2;
}
/** Check if a binary relation is cyclic
*
* @param x square logical matrix
* @return logical scalar
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_is_cyclic(SEXP x)
{
x = prepare_arg_logical_square_matrix(x, "R");
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
for (int i=0; i<n*n; ++i)
if (xp[i] == NA_LOGICAL)
return Rf_ScalarLogical(NA_LOGICAL);
int* helper = new int[n];
for (int i=0; i<n; ++i)
helper[i] = 0;
bool ret = false;
int i=0;
do {
while (i < n) { if (helper[i] == 0) break; i++; } // get an unmarked node
if (i == n) break;
ret = rel_is_cyclic(i, xp, n, helper);
} while(!ret);
delete[] helper;
return Rf_ScalarLogical(ret);
}
std::string get_single_class(SEXP x) {
SEXP klass = Rf_getAttrib(x, R_ClassSymbol);
if (!Rf_isNull(klass)) {
CharacterVector classes(klass);
return collapse_utf8(classes);
}
if (Rf_isMatrix(x)) {
return "matrix";
}
switch (TYPEOF(x)) {
case INTSXP:
return "integer";
case REALSXP :
return "numeric";
case LGLSXP:
return "logical";
case STRSXP:
return "character";
case VECSXP:
return "list";
default:
break;
}
// just call R to deal with other cases
// we could call R_data_class directly but we might get a "this is not part of the api"
klass = Rf_eval(Rf_lang2(Rf_install("class"), x), R_GlobalEnv);
return CHAR(STRING_ELT(klass,0));
}
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
);
}
}
void getMatrixDims(SEXP r_theta, int *rows, int *cols)
{
SEXP matrixDims;
ScopedProtect p1(matrixDims, Rf_getAttrib(r_theta, R_DimSymbol));
int *dimList = INTEGER(matrixDims);
*rows = dimList[0];
*cols = dimList[1];
}
void getMatrixDims(SEXP r_theta, int *rows, int *cols)
{
SEXP matrixDims;
Rf_protect(matrixDims = Rf_getAttrib(r_theta, R_DimSymbol));
int *dimList = INTEGER(matrixDims);
*rows = dimList[0];
*cols = dimList[1];
UNPROTECT(1);
}
/**
* Gets the dim attribute vector of a SEXP. This may be the only
* place were we use R's low-level macros, and these functions
* are not really needed anyway since the dimension info is
* directly available from Rcpp::NumericVector, Rcpp::NumericMatrix.
*/
std::vector<int> getRDims(SEXP s) {
SEXP dimAttr = Rf_getAttrib(s, R_DimSymbol);
if(dimAttr == R_NilValue)
return std::vector<int>(0);
int len = Rf_length(dimAttr);
std::vector<int> dims(len);
for(int i=0; i < len; ++i)
dims[i] = INTEGER(dimAttr)[i];
return dims;
}
/* get the list element named str, or return NULL */
SEXP getListElement(SEXP list, const char *str)
{
SEXP elmt = R_NilValue, names = Rf_getAttrib(list, R_NamesSymbol);
int i;
for (i = 0; i < Rf_length(list); i++)
if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
elmt = VECTOR_ELT(list, i);
break;
}
return elmt;
}
SEXP getRListOrDfElement(SEXP list_or_df, const char* element_name) {
SEXP names = Rf_getAttrib(list_or_df, R_NamesSymbol);
SEXP element = R_NilValue;
int i;
for (i = 0; i < Rf_length(list_or_df); i++) {
if (strcmp(CHAR(STRING_ELT(names, i)), element_name) == 0) {
element = VECTOR_ELT(list_or_df, i);
break;
}
}
return element;
}
std::vector<int> GetArrayDimensions(SEXP array) {
if (!Rf_isArray(array)) {
report_error("GetArrayDimensions called on a non-array object.");
}
SEXP r_dims = PROTECT(Rf_getAttrib(array, R_DimSymbol));
std::vector<int> dims(Rf_length(r_dims));
int *rdims = INTEGER(r_dims);
for (int i = 0; i < dims.size(); ++i) {
dims[i] = rdims[i];
}
UNPROTECT(1);
return dims;
}
/***
* used both in stri_sub and stri_sub_replacement
*
* @return number of objects PROTECTEd
*/
R_len_t stri__sub_prepare_from_to_length(SEXP& from, SEXP& to, SEXP& length,
R_len_t& from_len, R_len_t& to_len, R_len_t& length_len,
int*& from_tab, int*& to_tab, int*& length_tab)
{
R_len_t sub_protected = 0;
bool from_ismatrix = Rf_isMatrix(from);
if (from_ismatrix) {
SEXP t;
PROTECT(t = Rf_getAttrib(from, R_DimSymbol));
if (INTEGER(t)[1] == 1)
from_ismatrix = false; /* it's a column vector */
else if (INTEGER(t)[1] > 2) {
/* error() is allowed here */
UNPROTECT(1); // t
Rf_error(MSG__ARG_EXPECTED_MATRIX_WITH_GIVEN_COLUMNS, "from", 2);
}
UNPROTECT(1); // t
}
sub_protected++;
PROTECT(from = stri_prepare_arg_integer(from, "from"));
/* may remove R_DimSymbol */
if (from_ismatrix) {
from_len = LENGTH(from)/2;
to_len = from_len;
from_tab = INTEGER(from);
to_tab = from_tab+from_len;
//PROTECT(to); /* fake - not to provoke stack imbalance */
//PROTECT(length); /* fake - not to provoke stack imbalance */
}
else if (isNull(length)) {
sub_protected++;
PROTECT(to = stri_prepare_arg_integer(to, "to"));
from_len = LENGTH(from);
from_tab = INTEGER(from);
to_len = LENGTH(to);
to_tab = INTEGER(to);
//PROTECT(length); /* fake - not to provoke stack imbalance */
}
else {
sub_protected++;
PROTECT(length= stri_prepare_arg_integer(length, "length"));
from_len = LENGTH(from);
from_tab = INTEGER(from);
length_len = LENGTH(length);
length_tab = INTEGER(length);
//PROTECT(to); /* fake - not to provoke stack imbalance */
}
return sub_protected;
}
SEXP as_output_matrix(SEXP sMat, SEXP sNrow, SEXP sNcol, SEXP sSep, SEXP sNsep, SEXP sRownamesFlag, SEXP sConn) {
R_xlen_t nrow = asLong(sNrow, -1);
R_xlen_t ncol = asLong(sNcol, -1);
if (nrow < 0 || ncol < 0)
Rf_error("invalid/missing matrix dimensions");
int rownamesFlag = asInteger(sRownamesFlag);
if (TYPEOF(sSep) != STRSXP || LENGTH(sSep) != 1)
Rf_error("sep must be a single string");
if (TYPEOF(sNsep) != STRSXP || LENGTH(sNsep) != 1)
Rf_error("nsep must be a single string");
char sep = CHAR(STRING_ELT(sSep, 0))[0];
char nsep = CHAR(STRING_ELT(sNsep, 0))[0];
char lend = '\n';
SEXPTYPE what = TYPEOF(sMat);
SEXP sRnames = Rf_getAttrib(sMat, R_DimNamesSymbol);
sRnames = isNull(sRnames) ? 0 : VECTOR_ELT(sRnames,0);
int isConn = inherits(sConn, "connection");
R_xlen_t row_len = ((R_xlen_t) guess_size(what)) * (R_xlen_t) ncol;
if (rownamesFlag) row_len += 8;
SEXP buf = dybuf_alloc(isConn ? DEFAULT_CONN_BUFFER_SIZE : (row_len * nrow), sConn);
R_xlen_t i, j;
for (i = 0; i < nrow; i++) {
if (rownamesFlag) {
if (sRnames) {
const char *c = CHAR(STRING_ELT(sRnames, i));
dybuf_add(buf, c, strlen(c));
}
dybuf_add1(buf, nsep);
}
for (j = 0; j < ncol; j++) {
R_xlen_t pos = j;
pos *= nrow;
pos += i;
if (j) dybuf_add1(buf, sep);
store(buf, sMat, pos);
}
dybuf_add1(buf, lend);
}
SEXP res = dybuf_collect(buf);
UNPROTECT(1); /* buffer */
return res;
}
