/**
* Set the SSL certificate-authority locations
*
* Either parameter may be 'NULL', but not both.
* @param filename Location of a file containing several certificates
* concatenated together. Default NULL.
* @param path Location of a directory holding several certificates,
* one per file. Default NULL.
* @return NULL
*/
SEXP git2r_ssl_cert_locations(SEXP filename, SEXP path)
{
const char *f = NULL;
const char *p = NULL;
if (!Rf_isNull(filename)) {
if (git2r_arg_check_string(filename))
git2r_error(__func__, NULL, "'filename'", git2r_err_string_arg);
f = CHAR(STRING_ELT(filename, 0));
}
if (!Rf_isNull(path)) {
if (git2r_arg_check_string(path))
git2r_error(__func__, NULL, "'path'", git2r_err_string_arg);
p = CHAR(STRING_ELT(path, 0));
}
if (f == NULL && p == NULL)
git2r_error(__func__, NULL, git2r_err_ssl_cert_locations, NULL);
if (git_libgit2_opts(GIT_OPT_SET_SSL_CERT_LOCATIONS, f, p))
git2r_error(__func__, GIT2R_ERROR_LAST(), NULL, NULL);
return R_NilValue;
}
RData *RKStructureGetter::getStructure (SEXP toplevel, SEXP name, SEXP envlevel, SEXP namespacename) {
RK_TRACE (RBACKEND);
QString name_string = RKRSupport::SEXPToString (name);
// resolve namespace, if needed
if (Rf_isNull (namespacename)) {
with_namespace = false;
} else {
SEXP as_ns_fun = Rf_findFun (Rf_install (".rk.try.get.namespace"), R_GlobalEnv);
PROTECT (as_ns_fun);
RK_ASSERT (!Rf_isNull (as_ns_fun));
namespace_envir = RKRSupport::callSimpleFun (as_ns_fun, namespacename, R_GlobalEnv);
with_namespace = !Rf_isNull (namespace_envir);
UNPROTECT (1); /* as_ns_fun */
}
if (with_namespace) PROTECT (namespace_envir);
RData *ret = new RData;
toplevel_value = toplevel;
getStructureSafe (toplevel, name_string, 0, ret, INTEGER (envlevel)[0]);
if (with_namespace) UNPROTECT (1); /* namespace_envir */
return ret;
}
SEXP null_to_na_(SEXP x) {
SEXP na_vector = PROTECT(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(na_vector, 0, NA_STRING);
// One element for each row
int n = Rf_length(x);
for (int i = 0; i < n; ++i) {
SEXP row = VECTOR_ELT(x, i);
SEXP f = VECTOR_ELT(row, 0);
int p = Rf_length(f);
for (int j = 0; j < p; ++j) {
SEXP val = VECTOR_ELT(f, j);
if (Rf_isNull(val)) {
SEXP v = PROTECT(Rf_allocVector(VECSXP, 1));
SET_VECTOR_ELT(v, 0, Rf_duplicate(na_vector));
SET_VECTOR_ELT(f, j, v);
UNPROTECT(1);
} else if (Rf_isNull(VECTOR_ELT(val, 0))) {
SET_VECTOR_ELT(val, 0, Rf_duplicate(na_vector));
}
}
}
UNPROTECT(1);
return(x);
}
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;
}
void check_attribute_compatibility(SEXP left, SEXP right) {
SEXP att_left = ATTRIB(left);
SEXP att_right = ATTRIB(right);
int n_left = count_attributes(att_left);
int n_right = count_attributes(att_right);
if (Rf_inherits(left, "POSIXct") && Rf_inherits(right, "POSIXct")) {
return;
}
if (n_left != n_right)
stop("attributes of different sizes");
List list_left(n_left), list_right(n_left);
SEXP p_left = att_left;
int i = 0;
while (!Rf_isNull(p_left)) {
SEXP name = TAG(p_left);
if (name != R_NamesSymbol && name != R_DimSymbol) {
list_left[i] = CAR(p_left);
list_right[i] = grab_attribute(name, att_right);
}
p_left = CDR(p_left);
}
RObject test = Language("all.equal", list_left, list_right).fast_eval();
if (!is<bool>(test) || !as<bool>(test)) {
stop("attributes are different");
}
}
RcppExport SEXP joint_dur_dur_times(SEXP time_diffs,SEXP i_,SEXP j_,SEXP absorb_states,SEXP eigen_decomp,SEXP exact_time_rank){
int i=Rcpp::as<int>(j_);
int j=Rcpp::as<int>(i_);
Rcpp::List eigen_dec=Rcpp::as<Rcpp::List>(eigen_decomp);
arma::colvec times=Rcpp::as<arma::colvec>(time_diffs);
arma::mat Q=Rcpp::as<arma::mat>(eigen_dec["rate"]);
arma::cube out=arma::zeros<arma::cube>(Q.n_rows,Q.n_rows,times.n_elem);
for(int l=0; l<times.n_elem;l++){
if(Rf_isNull(exact_time_rank)==0){
arma::ivec absorb=Rcpp::as<arma::ivec>(absorb_states);
int exact_time_index=Rcpp::as<int>(exact_time_rank)-2;
if(l==exact_time_index){
out.slice(l)=joint_dur_dur_exact_time(i,j, times(l), absorb,eigen_decomp);
}else{
out.slice(l)=joint_duration_2moment(i, j,eigen_decomp, times(l));
}
}else{
out.slice(l)=joint_duration_2moment(i, j,eigen_decomp, times(l));
}
}
return(Rcpp::wrap(out));
}
RcppExport SEXP joint_trans_dur_times(SEXP time_diffs,SEXP d1_,SEXP tr1_,SEXP tr2_,SEXP absorb_state,SEXP eigen_decomp,SEXP exact_time_rank){
int d1=Rcpp::as<int>(d1_);
int tr1=Rcpp::as<int>(tr1_);
int tr2=Rcpp::as<int>(tr2_);
Rcpp::List eigen_dec=Rcpp::as<Rcpp::List>(eigen_decomp);
arma::colvec times=Rcpp::as<arma::colvec>(time_diffs);
arma::mat Q=Rcpp::as<arma::mat>(eigen_dec["rate"]);
arma::cube out=arma::zeros<arma::cube>(Q.n_rows,Q.n_rows,times.n_elem);
for(int l=0; l<times.n_elem;l++){
if(Rf_isNull(exact_time_rank)==0){
arma::ivec absorb=Rcpp::as<arma::ivec>(absorb_state);
int exact_time_index=Rcpp::as<int>(exact_time_rank)-2;
if(l==exact_time_index){
out.slice(l)= joint_dur_trans_exact_time(d1, tr1, tr2, absorb, eigen_decomp, times(l));
}else{
out.slice(l)=joint_dur_trans_2moment(d1, tr1, tr2, eigen_decomp, times(l));
}
}else{
out.slice(l)=joint_dur_trans_2moment(d1, tr1, tr2, eigen_decomp, times(l));
}
}
return(Rcpp::wrap(out));
}
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 ;
}
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());
}
}
}
}
RcppExport SEXP DeserializeFlann(SEXP x,SEXP m) {
try {
Rcpp::XPtr< flann::Index<flann::L2<float> > > oldindex(x);
if(oldindex)
return x;
if(Rf_isNull(m))
::Rf_error("Please serialize");
Rcpp::NumericMatrix dataset(m);
flann::Matrix<float> input(new float[dataset.nrow()*dataset.ncol()], dataset.nrow(), dataset.ncol());
//#pragma omp parallel for
for( int j = 0; j < dataset.nrow(); j++) {
for (int i = 0; i < dataset.ncol(); i++)
input[j][i] = dataset(j,i);
}
flann::Index<flann::L2<float> >* index = new flann::Index<flann::L2<float> >(input,flann::KDTreeSingleIndexParams());
index->buildIndex();
Rcpp::XPtr< flann::Index<flann::L2<float> > > p(index, true);
return p; // -Wall
} catch( std::exception &ex ) { // or use END_RCPP macro
forward_exception_to_r( ex );
} catch(...) {
::Rf_error( "c++ exception (unknown reason)" );
}
return R_NilValue; // -Wall
}
SEXP R_mongo_collection_update(SEXP ptr_col, SEXP ptr_selector, SEXP ptr_update, SEXP ptr_filters, SEXP upsert, SEXP multiple, SEXP replace){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *selector = r2bson(ptr_selector);
bson_t *update = r2bson(ptr_update);
bool success;
bson_t opts;
bson_init (&opts);
BSON_APPEND_BOOL (&opts, "upsert", Rf_asLogical(upsert));
if(!Rf_isNull(ptr_filters))
BSON_APPEND_ARRAY (&opts, "arrayFilters", r2bson(ptr_filters));
bson_error_t err;
bson_t reply;
if(Rf_asLogical(replace)){
success = mongoc_collection_replace_one(col, selector, update, &opts, &reply, &err);
} else {
success = Rf_asLogical(multiple) ?
mongoc_collection_update_many(col, selector, update, &opts, &reply, &err) :
mongoc_collection_update_one(col, selector, update, &opts, &reply, &err);
}
if(!success)
stop(err.message);
return bson2list(&reply);
}
// [[Rcpp::export]]
Rcpp::List mlist2clist(Rcpp::List mlist, int nthreads=1){
if (mlist.length()==0) Rcpp::stop("empty list is invalid");
int ncounts, nmarks, nbins = -1;
std::vector<std::string> foo;
listcubedim(mlist, &nbins, &ncounts, &nmarks, foo);
Rcpp::List newdnames(2); newdnames[0] = mlist.attr("names");
//allocate storage
Rcpp::List clist(ncounts);
for (int c = 0; c < ncounts; ++c){
Rcpp::IntegerMatrix mat(nmarks, nbins);
if (!Rf_isNull(newdnames[0])) mat.attr("dimnames") = newdnames;
clist[c] = mat;
}
//copy data
#pragma omp parallel for num_threads(nthreads) collapse(2)
for (int c = 0; c < ncounts; ++c){
for (int mark = 0; mark < nmarks; ++mark){
Vec<int> col = Mat<int>((SEXP)mlist[mark]).getCol(c);
MatRow<int> row = Mat<int>((SEXP)clist[c]).getRow(mark);
for (int bin = 0; bin < nbins; ++bin){
row[bin] = col[bin];
}
}
}
return clist;
}
SEXP grab_attribute(SEXP name, SEXP x) {
while (!Rf_isNull(x)) {
if (TAG(x) == name) return CAR(x);
x = CDR(x);
}
stop("cannot find attribute '%s' ", SymbolString(Symbol(name)).get_utf8_cstring());
}
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));
}
/**
* Callback when iterating over stashes
*
* @param index The position within the stash list. 0 points to the
* most recent stashed state.
* @param message The stash message.
* @param stash_id The commit oid of the stashed state.
* @param payload Pointer to a git2r_stash_list_cb_data data structure.
* @return 0 if OK, else error code
*/
static int git2r_stash_list_cb(
size_t index,
const char* message,
const git_oid *stash_id,
void *payload)
{
int error = 0, nprotect = 0;
SEXP stash, class;
git2r_stash_list_cb_data *cb_data = (git2r_stash_list_cb_data*)payload;
/* Check if we have a list to populate */
if (!Rf_isNull(cb_data->list)) {
PROTECT(class = Rf_allocVector(STRSXP, 2));
nprotect++;
SET_STRING_ELT(class, 0, Rf_mkChar("git_stash"));
SET_STRING_ELT(class, 1, Rf_mkChar("git_commit"));
PROTECT(stash = Rf_mkNamed(VECSXP, git2r_S3_items__git_commit));
nprotect++;
Rf_setAttrib(stash, R_ClassSymbol, class);
error = git2r_stash_init(
stash_id,
cb_data->repository,
cb_data->repo,
stash);
if (error)
goto cleanup;
SET_VECTOR_ELT(cb_data->list, cb_data->n, stash);
}
RKStructureGetter::RKStructureGetter (bool keep_evalled_promises) {
RK_TRACE (RBACKEND);
RKStructureGetter::keep_evalled_promises = keep_evalled_promises;
num_prefetched_funs = 0;
meta_attrib = Rf_install (".rk.meta");
PROTECT (meta_attrib);
RK_ASSERT (!Rf_isNull (meta_attrib));
class_fun = prefetch_fun ("class");
get_meta_fun = prefetch_fun (".rk.get.meta", false);
// Why do we need all these? Because the is.xxx functions may do an internal dispatch, that we do not want to miss, but don't easily get by e.g. calling Rf_isFunction() directly.
is_matrix_fun = prefetch_fun ("is.matrix");
is_array_fun = prefetch_fun ("is.array");
is_list_fun = prefetch_fun ("is.list");
is_function_fun = prefetch_fun ("is.function");
is_environment_fun = prefetch_fun ("is.environment");
is_factor_fun = prefetch_fun ("is.factor");
is_numeric_fun = prefetch_fun ("is.numeric");
is_character_fun = prefetch_fun ("is.character");
is_logical_fun = prefetch_fun ("is.logical");
double_brackets_fun = prefetch_fun ("[[");
dims_fun = prefetch_fun ("dim");
names_fun = prefetch_fun ("names");
length_fun = prefetch_fun ("length");
get_formals_fun = prefetch_fun (".rk.get.formals", false);
}
void DataFrameVisitors::structure( List& x, int nrows, CharacterVector classes ) const {
x.attr( "class" ) = classes ;
set_rownames(x, nrows) ;
x.names() = visitor_names ;
SEXP vars = data.attr( "vars" ) ;
if( !Rf_isNull(vars) )
x.attr( "vars" ) = vars ;
}
static SEXP get_last_call(){
SEXP sys_calls_symbol = Rf_install( "sys.calls" ) ;
Scoped<SEXP> sys_calls_expr = Rf_lang1(sys_calls_symbol) ;
Scoped<SEXP> calls = Rf_eval( sys_calls_expr, R_GlobalEnv ) ;
SEXP res = calls ;
while( !Rf_isNull(CDR(res)) ) res = CDR(res);
return CAR(res) ;
}
RcppExport SEXP trans_loop(SEXP likelihood_forward_backward,SEXP time_diffs_list, SEXP eigen_decomp_list, SEXP obs_data_list,
SEXP emission_list, SEXP exact_time_ranks_list,SEXP the_state_size,SEXP absorb_state,SEXP ij_indices,SEXP time_dep_emission){
arma::imat state_pairs=Rcpp::as<arma::imat>(ij_indices);
int num_state_pairs=state_pairs.n_rows;
Rcpp::List llfb(likelihood_forward_backward);
Rcpp::List time_diff(time_diffs_list);
Rcpp::List eigen_list(eigen_decomp_list);
Rcpp::List obsdata_list(obs_data_list);
Rcpp::List emission(emission_list);
Rcpp::List exact_time_ranks(exact_time_ranks_list);
bool time_dep=Rcpp::as<bool>(time_dep_emission);
int state_size=Rcpp::as<int>(the_state_size);
int num_subjects=eigen_list.size();
arma::cube expected_trans_array=arma::zeros<arma::cube>(state_size,state_size,num_subjects);
for(int i=0; i<num_state_pairs; i++){
for(int k=0; k<num_subjects;k++){
Rcpp::List indivEigen=Rcpp::as<Rcpp::List>(eigen_list[k]);
arma::vec indivTime=Rcpp::as<arma::vec>(time_diff[k]);
arma::icolvec obsdata=Rcpp::as<arma::icolvec>(obsdata_list[k]);
Rcpp::List indivLLFB=Rcpp::as<Rcpp::List>(llfb[k]);
arma::mat logalpha=Rcpp::as<arma::mat>(indivLLFB["logalpha"]);
arma::mat logbeta=Rcpp::as<arma::mat>(indivLLFB["logbeta"]);
double LL=Rcpp::as<double>(indivLLFB["LL"]);
int size=indivTime.n_elem;
std::vector<arma::mat> joint_means_trans(size);
arma::mat regist_matrix=arma::zeros<arma::mat>(state_size,state_size);
regist_matrix(state_pairs(i,0)-1,state_pairs(i,1)-1)=1;
for(int l=0; l<size;l++){
joint_means_trans[l]=joint_mean_markov_jumps_cpp(indivEigen,regist_matrix, indivTime(l));
}
if(Rf_isNull(exact_time_ranks[k])==0){
int exact_time_index=Rcpp::as<int>(exact_time_ranks[k])-2;
arma::ivec the_absorb_state=Rcpp::as<arma::ivec>(absorb_state);
int start_state=state_pairs(i,0);
int end_state=state_pairs(i,1);
joint_means_trans[exact_time_index]=exact_trans(joint_means_trans,indivEigen,indivTime(exact_time_index),the_absorb_state, start_state,end_state,exact_time_index);
}
if(time_dep==false){
arma::mat indivEmission=Rcpp::as<arma::mat>(emission[k]);
expected_trans_array(state_pairs(i,0)-1,state_pairs(i,1)-1,k)=get_mean_cpp(joint_means_trans,obsdata, logalpha, logbeta, LL, indivEmission);
}else{
Rcpp::List indivEmissionList=Rcpp::as<Rcpp::List>(emission[k]);
expected_trans_array(state_pairs(i,0)-1,state_pairs(i,1)-1,k)=get_mean_cpp_time_dep_emission(joint_means_trans,obsdata, logalpha, logbeta, LL, indivEmissionList);
}
}
}
return(Rcpp::wrap(expected_trans_array));
}
void seed_rng_from_R(SEXP rseed) {
if (Rf_isNull(rseed)) {
BOOM::GlobalRng::seed_with_timestamp();
} else {
int seed = Rf_asInteger(rseed);
BOOM::GlobalRng::rng.seed(seed);
srand(seed);
}
}
SEXP get_last_call(){
SEXP sys_calls_symbol = Rf_install( "sys.calls" ) ;
SEXP sys_calls_expr = PROTECT( Rf_lang1(sys_calls_symbol) ) ;
SEXP calls = PROTECT( Rf_eval( sys_calls_expr, R_GlobalEnv ) ) ;
SEXP res = calls ;
while( !Rf_isNull(CDR(res)) ) res = CDR(res);
UNPROTECT(2);
return CAR(res) ;
}
int count_attributes(SEXP x) {
int n = 0;
while (! Rf_isNull(x)) {
SEXP name = TAG(x);
if (name != R_NamesSymbol && name != R_DimSymbol) n++;
x = CDR(x);
}
return n;
}
/* Return -1 on failure */
int
Sexp_ndims(const SEXP sexp) {
if (! RINTERF_ISREADY()) {
return -1;
}
SEXP dims = getAttrib(sexp, R_DimSymbol);
int res;
if (Rf_isNull(dims))
res = 1;
else
res = LENGTH(dims);
return res;
}
RData *RKStructureGetter::getStructure (SEXP toplevel, SEXP name, SEXP envlevel, SEXP namespacename) {
RK_TRACE (RBACKEND);
// TODO: accept an envlevel parameter
envir_depth = INTEGER (envlevel)[0];
unsigned int count;
QString *name_dummy = SEXPToStringList (name, &count);
RK_ASSERT (count == 1);
QString name_string = name_dummy[0];
delete [] name_dummy;
// resolve namespace, if needed
if (Rf_isNull (namespacename)) {
with_namespace = false;
} else {
with_namespace = true;
SEXP as_ns_fun = Rf_findFun (Rf_install (".rk.try.get.namespace"), R_GlobalEnv);
PROTECT (as_ns_fun);
RK_ASSERT (!Rf_isNull (as_ns_fun));
namespace_envir = callSimpleFun (as_ns_fun, namespacename, R_GlobalEnv);
UNPROTECT (1); /* as_ns_fun */
PROTECT (namespace_envir);
}
RData *ret = new RData;
getStructureSafe (toplevel, name_string, false, ret);
if (with_namespace) {
UNPROTECT (1); /* namespace_envir */
}
return ret;
}
/* Return NULL on failure */
SEXP
Sexp_getAttribute(const SEXP sexp,
char *name) {
if (! RINTERF_ISREADY()) {
return NULL;
}
SEXP res = Rf_getAttrib(sexp, Rf_install(name));
if (Rf_isNull(res)) {
res = NULL;
} else {
R_PreserveObject(res);
}
return res;
}
SEXP getListElement(SEXP list, const std::string &name){
SEXP elmt = R_NilValue;
SEXP names = Rf_getAttrib(list, R_NamesSymbol);
if(Rf_isNull(names)){
report_error("attempt to use getListElement in a list with"
" no 'names' attribute.");
}
for(int i = 0; i < Rf_length(list); i++)
if(name == CHAR(STRING_ELT(names, i))){
elmt = VECTOR_ELT(list, i);
break;
}
return elmt;
}
std::vector<std::string> StringVector(SEXP r_character_vector) {
if (Rf_isNull(r_character_vector)) {
return std::vector<std::string>();
} else if (!Rf_isString(r_character_vector)) {
report_error("StringVector expects a character vector argument");
}
int n = Rf_length(r_character_vector);
std::vector<std::string> ans;
ans.reserve(n);
for(int i = 0; i < n; ++i){
ans.push_back(CHAR(STRING_ELT(r_character_vector, i)));
}
return ans;
}
Result* firstlast_prototype(SEXP call, const ILazySubsets& subsets, int nargs, int pos) {
SEXP tail = CDDR(call);
SETCAR(call, Rf_install("nth"));
Pairlist p(pos);
if (Rf_isNull(tail)) {
SETCDR(CDR(call), p);
} else {
SETCDR(p, tail);
SETCDR(CDR(call), p);
}
Result* res = nth_prototype(call, subsets, nargs + 1);
return res;
}
SEXP RKStructureGetter::prefetch_fun (const char *name, bool from_base) {
SEXP ret;
if (from_base) {
ret = Rf_install (name);
} else {
ret = Rf_findFun (Rf_install (name), R_GlobalEnv);
}
PROTECT (ret);
RK_ASSERT (!Rf_isNull (ret));
++num_prefetched_funs;
return (ret);
}
RcppExport SEXP trans_times(SEXP ni,SEXP nj, SEXP time_diffs_list, SEXP eigen_decomp_list, SEXP the_state_size, SEXP exact_time_ranks_list,SEXP absorb_state){
int test=3;
Rcpp::List time_diff(time_diffs_list);
Rcpp::List eigen_list(eigen_decomp_list);
Rcpp::List exact_time_ranks(exact_time_ranks_list);
int state_size=Rcpp::as<int>(the_state_size);
int num_subjects=eigen_list.size();
Rcpp::List indivEigen=Rcpp::as<Rcpp::List>(eigen_list[0]);
arma::mat rate_matrix=Rcpp::as<arma::mat>(indivEigen["rate"]);
arma::vec indivTime=Rcpp::as<arma::vec>(time_diff[0]);
int size=indivTime.n_elem;
arma::cube joint_means_trans(state_size, state_size, size);
int k=0;
int i=Rcpp::as<int>(ni);
int j=Rcpp::as<int>(nj);
arma::mat regist_matrix=arma::zeros<arma::mat>(state_size,state_size);
regist_matrix(i-1,j-1)=1;
for(int l=0; l<size;l++){
joint_means_trans.slice(l)=joint_mean_markov_jumps_cpp(indivEigen,regist_matrix, indivTime(l));
}
if(Rf_isNull(exact_time_ranks[k])==0){
int exact_time_index=Rcpp::as<int>(exact_time_ranks[k])-2;
arma::ivec the_absorb_state=Rcpp::as<arma::ivec>(absorb_state);
int start_state=i;
int end_state=j;
joint_means_trans.slice(exact_time_index)=exact_trans2(joint_means_trans,indivEigen,indivTime(exact_time_index),the_absorb_state, start_state,end_state,exact_time_index);
}
return(Rcpp::wrap(joint_means_trans));
// return(Rcpp::wrap(test));
}