Ejemplo n.º 1
0
/**
 * 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;
}
Ejemplo n.º 3
0
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);
}
Ejemplo n.º 4
0
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;
}
Ejemplo n.º 5
0
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");
  }
}
Ejemplo n.º 6
0
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));
}
Ejemplo n.º 7
0
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));
}
Ejemplo n.º 8
0
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 ;
}
Ejemplo n.º 9
0
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());
			}
		}
	}
}
Ejemplo n.º 10
0
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
}
Ejemplo n.º 11
0
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);
}
Ejemplo n.º 12
0
// [[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;
}
Ejemplo n.º 13
0
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());
}
Ejemplo n.º 14
0
  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));
  }
Ejemplo n.º 15
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);
}
Ejemplo n.º 17
0
 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 ;
 }
Ejemplo n.º 18
0
 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) ;
 }
Ejemplo n.º 19
0
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));
}
Ejemplo n.º 20
0
 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);
   }
 }
Ejemplo n.º 21
0
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) ;
}
Ejemplo n.º 22
0
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;
}
Ejemplo n.º 23
0
/* 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;
}
Ejemplo n.º 25
0
/* 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;
}
Ejemplo n.º 26
0
 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;
 }
Ejemplo n.º 27
0
 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;
 }
Ejemplo n.º 28
0
  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);
}
Ejemplo n.º 30
0
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));
}