Exemple #1
0
//' Update eigen values, vectors, and inverse matrices for irms
//'
//' @param tpm_prods array of transition probability matrix products
//' @param tpms array of transition probability matrices
//' @param pop_mat population level bookkeeping matrix
//' @param obstimes vector of observation times
//'
//' @return Updated eigenvalues, eigenvectors, and inverse matrices
// [[Rcpp::export]]
void tpmProdSeqs(Rcpp::NumericVector& tpm_prods, Rcpp::NumericVector& tpms, const Rcpp::IntegerVector obs_time_inds) {

        // Get indices
        int n_obs = obs_time_inds.size();
        Rcpp::IntegerVector tpmDims = tpms.attr("dim");

        // Ensure obs_time_inds starts at 0
        Rcpp::IntegerVector obs_inds = obs_time_inds - 1;

        // Set array pointers
        arma::cube prod_arr(tpm_prods.begin(), tpmDims[0], tpmDims[1], tpmDims[2], false);
        arma::cube tpm_arr(tpms.begin(), tpmDims[0], tpmDims[1], tpmDims[2], false);

        // Generate tpm products and store them in the appropriate spots in the tpm product array
        for(int j = 0; j < (n_obs - 1); ++j) {

                prod_arr.slice(obs_inds[j+1] - 1) = tpm_arr.slice(obs_inds[j+1] - 1);

                for(int k = (obs_inds[j+1] - 2); k > (obs_inds[j] - 1); --k) {

                        prod_arr.slice(k) = tpm_arr.slice(k) * prod_arr.slice(k + 1);
                }

        }
}
Exemple #2
0
// Bellman recursion using row rearrangement
//[[Rcpp::export]]
Rcpp::List Bellman(const arma::mat& grid,
                   Rcpp::NumericVector reward_,
                   const arma::cube& scrap,
                   Rcpp::NumericVector control_,
                   const arma::cube& disturb,
                   const arma::vec& weight) {
  // Passing R objects to C++
  const std::size_t n_grid = grid.n_rows;
  const std::size_t n_dim = grid.n_cols;
  const arma::ivec r_dims = reward_.attr("dim");
  const std::size_t n_pos = r_dims(3);
  const std::size_t n_action = r_dims(2);
  const std::size_t n_dec = r_dims(4) + 1;
  const arma::cube
      reward(reward_.begin(), n_grid, n_dim * n_action * n_pos, n_dec - 1, false);
  const arma::ivec c_dims = control_.attr("dim");
  arma::cube control2;
  arma::imat control;
  bool full_control;
  if (c_dims.n_elem == 3) {
    full_control = false;
    arma::cube temp_control2(control_.begin(), n_pos, n_action, n_pos, false);
    control2 = temp_control2;
  } else {
    full_control = true;
    arma::mat temp_control(control_.begin(), n_pos, n_action, false);
    control = arma::conv_to<arma::imat>::from(temp_control);
  }
  const std::size_t n_disturb = disturb.n_slices;
  // Bellman recursion
  arma::cube value(n_grid, n_dim * n_pos, n_dec);
  arma::cube cont(n_grid, n_dim * n_pos, n_dec - 1, arma::fill::zeros);
  arma::mat d_value(n_grid, n_dim);
  Rcpp::Rcout << "At dec: " << n_dec - 1 << "...";
  for (std::size_t pp = 0; pp < n_pos; pp++) {
    value.slice(n_dec - 1).cols(n_dim * pp, n_dim * (pp + 1) - 1) =
        scrap.slice(pp);
  }
  for (int tt = (n_dec - 2); tt >= 0; tt--) {
    Rcpp::Rcout << tt;
    // Approximating the continuation value
    for (std::size_t pp = 0; pp < n_pos; pp++) {
      cont.slice(tt).cols(n_dim * pp, n_dim * (pp + 1) - 1) =
          Expected(grid,
                   value.slice(tt + 1).cols(pp * n_dim, n_dim * (pp + 1) - 1),
                   disturb, weight);
    }
    Rcpp::Rcout << "..";
    // Optimise value function
    if (full_control) {
      BellmanOptimal(grid, control, value, reward, cont, tt);
    } else {
      BellmanOptimal2(grid, control2, value, reward, cont, tt);
    }
    Rcpp::Rcout << ".";
  }
  return Rcpp::List::create(Rcpp::Named("value") = value,
                            Rcpp::Named("expected") = cont);
}
Exemple #3
0
// kernel Dist function on a Grid
// [[Rcpp::export]]
Rcpp::NumericVector
KdeDist(const Rcpp::NumericMatrix & X
      , const Rcpp::NumericMatrix & Grid
      , const double                h
      , const Rcpp::NumericVector & weight
      , const bool printProgress
	) {
	const unsigned sampleNum = X.nrow();
	const unsigned dimension = Grid.ncol();
	const unsigned gridNum = Grid.nrow();
	// first = sum K_h(X_i, X_j), second = K_h(x, x), third = sum K_h(x, X_i)
	std::vector< double > firstValue;
	const double second = 1.0;
	std::vector< double > thirdValue;
	double firstmean;
	Rcpp::NumericVector kdeDistValue(gridNum);
	int counter = 0, percentageFloor = 0;
	int totalCount = sampleNum + gridNum;

	if (printProgress) {
		printProgressFrame(Rprintf);
	}

	firstValue = computeKernel< std::vector< double > >(
			X, X, h, weight, printProgress, Rprintf, counter, totalCount,
			percentageFloor);

	if (dimension <= 1) {
		thirdValue = computeKernel< std::vector< double > >(
				X, Grid, h, weight, printProgress, Rprintf, counter, totalCount,
				percentageFloor);
	}
	else {
		thirdValue = computeGaussOuter< std::vector< double > >(
				X, Grid, h, weight, printProgress, Rprintf, counter, totalCount,
				percentageFloor);
	}

	if (weight.size() == 1) {
		firstmean = std::accumulate(firstValue.begin(), firstValue.end(), 0.0) / sampleNum;
	}
	else {
		firstmean = std::inner_product(
				firstValue.begin(), firstValue.end(), weight.begin(), 0.0) / 
				std::accumulate(weight.begin(), weight.end(), 0.0);
	}

	for (unsigned gridIdx = 0; gridIdx < gridNum; ++gridIdx) {
		kdeDistValue[gridIdx] = std::sqrt(firstmean + second - 2 * thirdValue[gridIdx]);
	}

	if (printProgress) {
		Rprintf("\n");
	}

	return kdeDistValue;
}
Exemple #4
0
// [[Rcpp::export(.cpp_convolve)]]
Rcpp::NumericVector cpp_convolve(Rcpp::NumericVector xa, Rcpp::NumericVector xb) {
  int n_xa = xa.size(), n_xb = xb.size();
  Rcpp::NumericVector xab(n_xa + n_xb - 1);
  typedef Rcpp::NumericVector::iterator vec_iterator;
  vec_iterator ia = xa.begin(), ib = xb.begin();
  vec_iterator iab = xab.begin();
  for (int i = 0; i < n_xa; i++)
    for (int j = 0; j < n_xb; j++)
      iab[i + j] += ia[i] * ib[j];
  return xab;
}
// [[Rcpp::export]]
Rcpp::List worstcase_l1(Rcpp::NumericVector z, Rcpp::NumericVector q, double t){
    // resulting probability
    craam::numvec p;
    // resulting objective value
    double objective;

    craam::numvec vz(z.begin(), z.end()), vq(q.begin(), q.end());
    std::tie(p,objective) = craam::worstcase_l1(vz,vq,t);

    Rcpp::List result;
    result["p"] = Rcpp::NumericVector(p.cbegin(), p.cend());
    result["obj"] = objective;

    return result;
}
Exemple #6
0
    // Returns the linear predictor from the full step
    Rcpp::NumericVector
    densePred::gamma(const Rcpp::NumericVector& xwts,
		     const Rcpp::NumericVector& wtres)
	throw (std::runtime_error) {
	int n = d_X.nrow();
	if (xwts.size() != n || wtres.size() != n)
	    throw
		std::runtime_error("length(xwts) or length(wtres) != nrow(X)");
	arma::vec a_xwts = arma::vec(xwts.begin(), n, false, true),
	    a_wtres = arma::vec(wtres.begin(), n, false, true);
	arma::vec tmp = solve(diagmat(a_xwts) * a_X, a_wtres);
	std::copy(tmp.begin(), tmp.end(), a_delta.begin());
	d_coef = d_coef0 + d_delta;
	return NumericVector(wrap(a_X * a_coef));
    }
// [[Rcpp::export]]
Rcpp::NumericVector randomSample(Rcpp::NumericVector a, int n) {
    // clone a into b to leave a alone
    Rcpp::NumericVector b(n);
    __gnu_cxx::random_sample(a.begin(), a.end(), 
                             b.begin(), b.end(), randWrapper);
    return b;
}
Exemple #8
0
    Rcpp::NumericVector
    glmFamily::devResid(Rcpp::NumericVector const &mu,
			Rcpp::NumericVector const &weights,
			Rcpp::NumericVector const &y) const {
	if (devRes.count(d_family)) {
	    double (*f)(double, double, double) = devRes[d_family];
	    int nobs = mu.size();
	    NumericVector ans(nobs);
	    double *mm = mu.begin(), *ww = weights.begin(),
		*yy = y.begin(), *aa = ans.begin();
	    for (int i = 0; i < nobs; i++)
		aa[i] = f(yy[i], mm[i], ww[i]);
	    return ans;
	}
	return d_devRes(y, mu, weights);
    }
Exemple #9
0
//' rcpp_neutral_hotspots_ntests
//'
//' Performs repeated neutral tests to yield average distributions of both
//' hotspot values and spatial autocorrelation statistics.
//'
//' @param nbs An \code{spdep} \code{nb} object listing all neighbours of each
//' point. 
//' @param wts Weighting factors for each neighbour; must have same length as
//' nbs. 
//' @param nbsi List of matrices as returned from \code{get_nbsi}. each element
//' of which contains the i-th nearest neighbour to each point.
//' @param alpha Strength of spatial autocorrelation
//' @param sd0 Standard deviation of truncated normal distribution used to model
//' environmental variation (with mean of 1)
//' @param nt Number of successive layers of temporal and spatial autocorrelation
//' used to generate final modelled values
//' @param ntests Number of tests used to obtain average values
//' @param ac_type Character string specifying type of aucorrelation
//' (\code{moran}, \code{geary}, or code{getis-ord}).
//'
//' @return A matrix of dimension (size, 2), with first column containing
//' sorted and re-scaled hotspot values, and second column containing sorted and
//' re-scaled spatial autocorrelation statistics.
//'
// [[Rcpp::export]]
Rcpp::NumericMatrix rcpp_neutral_hotspots_ntests (Rcpp::List nbs, 
        Rcpp::List wts, Rcpp::List nbsi, double alpha, double sd0, int niters,
        std::string ac_type, bool log_scale, int ntests)
{
    const int size = nbs.size ();

    Rcpp::NumericMatrix hs1;
    Rcpp::NumericVector z (size), z1 (size), ac (size), ac1 (size);
    std::fill (ac.begin (), ac.end (), 0.0);
    std::fill (z.begin (), z.end (), 0.0);

    for (int n=0; n<ntests; n++)
    {
        hs1 = rcpp_neutral_hotspots (nbs, wts, nbsi, alpha, sd0, log_scale,
                niters, ac_type);

        z += hs1 (Rcpp::_, 0);
        ac += hs1 (Rcpp::_, 1);
    }

    Rcpp::NumericMatrix result (size, 2);
    result (Rcpp::_, 0) = z / (double) ntests;
    result (Rcpp::_, 1) = ac / (double) ntests;
    Rcpp::colnames (result) = Rcpp::CharacterVector::create ("z", "ac");

    return result;
}
Exemple #10
0
void eigs_sym_shift_c(
    mat_op op, int n, int k, double sigma,
    const spectra_opts *opts, void *data,
    int *nconv, int *niter, int *nops,
    double *evals, double *evecs, int *info
)
{
    BEGIN_RCPP

    CRealShift cmat_op(op, n, data);
    Rcpp::List res;
    try {
        res = run_eigs_shift_sym((RealShift*) &cmat_op, n, k, opts->ncv, opts->rule,
                                 sigma, opts->maxitr, opts->tol, opts->retvec != 0);
        *info = 0;
    } catch(...) {
        *info = 1;  // indicates error
    }

    *nconv = Rcpp::as<int>(res["nconv"]);
    *niter = Rcpp::as<int>(res["niter"]);
    *nops  = Rcpp::as<int>(res["nops"]);
    Rcpp::NumericVector val = res["values"];
    std::copy(val.begin(), val.end(), evals);
    if(opts->retvec != 0)
    {
        Rcpp::NumericMatrix vec = res["vectors"];
        std::copy(vec.begin(), vec.end(), evecs);
    }

    VOID_END_RCPP
}
Exemple #11
0
    double lmerResp::updateMu(const Rcpp::NumericVector& gamma) {
#ifdef USE_RCPP_SUGAR
	d_mu = d_offset + gamma;
#else
	std::transform(gamma.begin(), gamma.end(), d_offset.begin(),
		       d_mu.begin(), std::plus<double>());
#endif
	return updateWrss();
    }
Exemple #12
0
// [[Rcpp::export]]
arma::mat rmvnorm_arma(int n,
                  const arma::vec& mu,
                  const arma::mat& Sigma) {
    unsigned int p = Sigma.n_cols;
    Rcpp::NumericVector draw = Rcpp::rnorm(n*p);
    arma::mat Z = arma::mat(draw.begin(), n, p, false, true);
    arma::mat Y = arma::repmat(mu, 1, n).t()+Z * arma::chol(Sigma);
    return Y;
}
Exemple #13
0
    // redis "set a vector" -- without R serialization, without attributes, ...
    // this is somewhat experimental
    std::string setVector(std::string key, Rcpp::NumericVector x) {

        redisReply *reply = 
            static_cast<redisReply*>(redisCommand(prc_, "SET %s %b", 
                                                  key.c_str(), x.begin(), x.size()*szdb));
        std::string res(reply->str);                                                
        freeReplyObject(reply);
        return(res);
    }
Exemple #14
0
void sampleScores(arma::mat& Z, arma::mat& A, arma::mat& F, Rcpp::NumericVector& sigma2inv, 
									int n, int k, int p) {
    arma::vec s2i(sigma2inv.begin(), p, false);
    arma::mat Sigma_inv = arma::diagmat(s2i);
    
    arma::mat U = my_randn(k, n);
    arma::mat fcov = arma::inv(arma::eye(k,k) + arma::trans(A)*Sigma_inv*A);
    arma::mat R = arma::chol(fcov);
    F = R*U + fcov*arma::trans(A)*Sigma_inv*Z;
}
// Calculate lk, k=1, ..., M with m0=0;
// where h=(h0, h1, ..., hM) with h0=0 and d=(d0, d1, ..., dM) with d0=0, dM=R_PosInf
void Getlk(Rcpp::NumericVector& lk, const Rcpp::IntegerVector& Mt, int M1, Rcpp::NumericVector d, 
           const Rcpp::NumericVector& t, const Rcpp::NumericVector& Xbeta){
  int n = Mt.size();
  std::fill(lk.begin(), lk.end(), 0);
  for (int k=1; k<M1; ++k){
    for (int i=0; i<n; ++i){
      if(Mt[i]>=k) lk[k] += (std::min(d[k],t[i])-d[k-1])*std::exp(Xbeta[i]);
    }
  }
}
Exemple #16
0
// gradient-descent ------------------------------------------------------------
//' @title Regular gradient descent for latent factor model with covariates
//' @param X The ratings matrix. Unobserved entries must be marked NA. Users
//' must be along rows, and tracks must be along columns.
//' @param Z The covariates associated with each pair. This must be shaped as an
//' array with users along rows, tracks along columns, and features along
//' slices.
//' @param k_factors The number of latent factors for the problem.
//' @param lambdas The regularization parameters for P, Q, and beta, respectively.
//' @param n_iter The number of gradient descent iterations to run.
//' @param batch_samples The proportion of the observed entries to sample in the
//' gradient for each factor in the gradient descent.
//' @param batch_factors The proportion of latent factors to update at each
//' iteration.
//' @param gamma The step-size in the gradient descent.
//' @param verbose Print the objective at each iteration of the descent?
//' @return A list with the following elements, \cr
//'   $P The learned user latent factors. \cr
//'   $Q The learned track latent factors. \cr
//'   $beta The learned regression coefficients.
//' @export
// [[Rcpp::export]]
Rcpp::List svd_cov(Rcpp::NumericMatrix X, Rcpp::NumericVector Z_vec,
		   int k_factors, Rcpp::NumericVector lambdas, int n_iter,
		   double batch_samples, double batch_factors,
		   double gamma_pq, double gamma_beta, bool verbose) {

  // convert to arma
  Rcpp::IntegerVector Z_dim = Z_vec.attr("dim");
  arma::cube Z(Z_vec.begin(), Z_dim[0], Z_dim[1], Z_dim[2], false);

  // initialize results
  int m = X.nrow();
  int n = X.ncol();
  int l = Z_dim[2];

  arma::mat P = 1.0 / sqrt(m) * arma::randn(m, k_factors);
  arma::mat Q = 1.0 / sqrt(n) * arma::randn(n, k_factors);
  arma::vec beta = 1.0 / sqrt(l) * arma::randn(l);
  arma::vec objs = arma::zeros(n_iter);

  // perform gradient descent steps
  for(int cur_iter = 0; cur_iter < n_iter; cur_iter++) {
    // update user factors
    arma::uvec cur_factors = get_batch_ix(m, batch_factors);
    for(int i = 0; i < cur_factors.n_elem; i++) {
      int cur_ix = cur_factors(i);
      P.row(cur_ix) = update_factor(X.row(cur_ix),
				    Z(arma::span(cur_ix), arma::span(), arma::span()),
				    arma::conv_to<arma::vec>::from(P.row(cur_ix)), Q, beta,
				    batch_samples, lambdas[0], gamma_pq).t();
    }

    // update track factors
    cur_factors = get_batch_ix(n, batch_factors);
    for(int j = 0; j < cur_factors.n_elem; j++) {
      int cur_ix = cur_factors(j);
      Q.row(cur_ix) = update_factor(X.column(cur_ix),
				    Z(arma::span(), arma::span(cur_ix), arma::span()),
				    arma::conv_to<arma::vec>::from(Q.row(cur_ix)), P, beta,
				    batch_samples, lambdas[1], gamma_pq).t();
    }

    // update regression coefficients
    beta = update_beta(Rcpp::as<arma::mat>(X), Z, P, Q, beta, lambdas[2], gamma_beta);
    objs[cur_iter] = objective_fun(Rcpp::as<arma::mat>(X), Z, P, Q, beta, lambdas);
    if(verbose) {
      printf("iteration %d \n", cur_iter);
      printf("Objective: %g \n", objs[cur_iter]);
    }
  }

  return Rcpp::List::create(Rcpp::Named("P") = P,
			    Rcpp::Named("Q") = Q,
			    Rcpp::Named("beta") = beta,
			    Rcpp::Named("objs") = objs);
}
Exemple #17
0
// [[Rcpp::export]]
SEXP EtaIndep  (Rcpp::NumericVector y_rcpp,
				Rcpp::NumericMatrix y_lagged_rcpp,
				Rcpp::NumericMatrix z_dependent_rcpp,
				Rcpp::NumericMatrix z_independent_rcpp,
				Rcpp::NumericVector beta_rcpp,
				Rcpp::NumericVector mu_rcpp,
				Rcpp::NumericVector sigma_rcpp,
				Rcpp::NumericMatrix gamma_dependent_rcpp,
				Rcpp::NumericVector gamma_independent_rcpp)
{
	int M = mu_rcpp.size();
	int n = y_rcpp.size();
	arma::mat eta(n, M);

	arma::colvec y(y_rcpp.begin(), y_rcpp.size(), false);
	arma::mat    y_lagged(y_lagged_rcpp.begin(),
												y_lagged_rcpp.nrow(), y_lagged_rcpp.ncol(), false);
	arma::mat    z_dependent(z_dependent_rcpp.begin(),
													z_dependent_rcpp.nrow(), z_dependent_rcpp.ncol(), false);
	arma::mat    z_independent(z_independent_rcpp.begin(),
														z_independent_rcpp.nrow(), z_independent_rcpp.ncol(), false);
	arma::colvec beta(beta_rcpp.begin(), beta_rcpp.size(), false);
	arma::colvec mu(mu_rcpp.begin(), mu_rcpp.size(), false);
	arma::colvec sigma(sigma_rcpp.begin(), sigma_rcpp.size(), false);
	arma::mat    gamma_dependent(gamma_dependent_rcpp.begin(),
																gamma_dependent_rcpp.nrow(), gamma_dependent_rcpp.ncol(), false);
	arma::colvec gamma_independent(gamma_independent_rcpp.begin(),
																	gamma_independent_rcpp.size(), false);


	for (int j = 0; j < M; j++)
	{
  	eta.col(j) = y - y_lagged * beta -
								z_dependent * gamma_dependent.col(j) -
								z_independent * gamma_independent - mu(j);
		eta.col(j) = eta.col(j) % eta.col(j); // element-wise multiplication
		eta.col(j) = exp(-eta.col(j) / (2 * (sigma(j) * sigma(j))));
		eta.col(j) = eta.col(j) / (SQRT2PI * sigma(j));
	}

	return (wrap(eta));
}
Exemple #18
0
    // redis "prepend to list" -- without R serialization
    // as above: pure vector, no attributes, ...
    std::string listLPush(std::string key, Rcpp::NumericVector x) {
        // uses binary protocol, see hiredis doc at github
        redisReply *reply = 
            static_cast<redisReply*>(redisCommand(prc_, "LPUSH %s %b", 
                                                  key.c_str(), x.begin(), x.size()*szdb));

        //std::string res(reply->str);                                                
        std::string res = "";
        freeReplyObject(reply);
        return(res);
    }
Exemple #19
0
    double glmerResp::updateMu(const Rcpp::NumericVector& gamma) {
#ifdef USE_RCPP_SUGAR
	d_eta = d_offset + gamma;
#else
	std::transform(d_offset.begin(), d_offset.end(), gamma.begin(),
		       d_eta.begin(), std::plus<double>());
#endif
	NumericVector mmu = d_fam.linkInv(d_eta);
	std::copy(mmu.begin(), mmu.end(), d_mu.begin());
	return updateWrss();
    }
Exemple #20
0
    /** 
     * Check and install new value of theta.  Update Lambda.
     * 
     * @param nt New value of theta
     */
    void reModule::setTheta(const Rcpp::NumericVector& nt)
	throw (std::runtime_error) {
	R_len_t nth = d_lower.size(), nLind = d_Lind.size();
	if (nt.size() != nth)
	    throw runtime_error("setTheta: size mismatch of nt and d_lower");
#ifdef USE_RCPP_SUGAR
	if (any(nt < d_lower).is_true()) // check that nt is feasible
	    throw runtime_error("setTheta: theta not in feasible region");
#else
	double *lp = d_lower.begin(), *ntp = nt.begin();
	for (R_len_t i = 0; i < nth; i++)
	    if (ntp[i] < lp[i])
		throw runtime_error("setTheta: theta not in feasible region");
#endif
	copy(nt.begin(), nt.end(), d_theta.begin());
				// update Lambda from theta and Lind
	double *Lamx = (double*)d_Lambda.x, *th = d_theta.begin();
	int *Li = d_Lind.begin();
	for (R_len_t i = 0; i < nLind; i++) Lamx[i] = th[Li[i] - 1];
    }
// [[Rcpp::export]]
SEXP FilterIndepOld  (Rcpp::NumericVector y_rcpp,
					Rcpp::NumericMatrix y_lagged_rcpp,
					Rcpp::NumericMatrix z_dependent_rcpp,
					Rcpp::NumericMatrix z_independent_rcpp,
					Rcpp::NumericVector beta_rcpp,
					Rcpp::NumericVector mu_rcpp,
					Rcpp::NumericVector sigma_rcpp,
					Rcpp::NumericMatrix gamma_dependent_rcpp,
					Rcpp::NumericVector gamma_independent_rcpp,
					Rcpp::NumericMatrix transition_probs_rcpp,
					Rcpp::NumericVector initial_dist_rcpp
					)
{
	int n = y_rcpp.size();
	int M = mu_rcpp.size();
	arma::mat xi_k_t(M, n); // make a transpose first for easier column operations.

	arma::colvec y(y_rcpp.begin(), y_rcpp.size(), false);
	arma::mat    y_lagged(y_lagged_rcpp.begin(),
								y_lagged_rcpp.nrow(), y_lagged_rcpp.ncol(), false);
	arma::mat    z_dependent(z_dependent_rcpp.begin(),
								z_dependent_rcpp.nrow(), z_dependent_rcpp.ncol(), false);
	arma::mat    z_independent(z_independent_rcpp.begin(),
								z_independent_rcpp.nrow(), z_independent_rcpp.ncol(), false);
	arma::colvec beta(beta_rcpp.begin(), beta_rcpp.size(), false);
	arma::colvec mu(mu_rcpp.begin(), mu_rcpp.size(), false);
	arma::colvec sigma(sigma_rcpp.begin(), sigma_rcpp.size(), false);
	arma::mat    gamma_dependent(gamma_dependent_rcpp.begin(),
								gamma_dependent_rcpp.nrow(), gamma_dependent_rcpp.ncol(), false);
	arma::colvec gamma_independent(gamma_independent_rcpp.begin(),
								gamma_independent_rcpp.size(), false);
	arma::mat    transition_probs(transition_probs_rcpp.begin(),
								transition_probs_rcpp.nrow(), transition_probs_rcpp.ncol(), false);
	arma::colvec initial_dist(initial_dist_rcpp.begin(), initial_dist_rcpp.size(), false);

	double likelihood = 0;

	SEXP eta_rcpp = EtaIndep(y_rcpp, y_lagged_rcpp,
						z_dependent_rcpp, z_independent_rcpp,
						beta_rcpp, mu_rcpp, sigma_rcpp,
						gamma_dependent_rcpp, gamma_independent_rcpp);
	arma::mat eta_t = (Rcpp::as<arma::mat>(eta_rcpp)).t();

	xi_k_t.col(0) = eta_t.col(0) % initial_dist;
	double total = sum(xi_k_t.col(0));
	xi_k_t.col(0) = xi_k_t.col(0) / total;
	likelihood += log(total);

	for (int k = 1; k < n; k++)
	{
	  	xi_k_t.col(k) = eta_t.col(k) % (transition_probs * xi_k_t.col(k-1));
	 	total = sum(xi_k_t.col(k));
		xi_k_t.col(k) = xi_k_t.col(k) / total;
		likelihood += log(total);
	}

	return Rcpp::List::create(Named("xi.k") = wrap(xi_k_t.t()),
														Named("likelihood") = wrap(likelihood));
}
//[[Rcpp::export]]
extern "C" SEXP aggregategsSumSigma( SEXP SDs, SEXP DOFs, SEXP geneSets) {
    Rcpp::NumericVector SD(SDs);
    Rcpp::NumericVector DOF(DOFs);
    Rcpp::List geneSet(geneSets);


//note this function assumes that each input is not NA
//calculates the sd and mindof in order , names are assigned in R

    int n = SD.size();
    int m = DOF.size();
    int o = geneSet.size(); //we assume non-empty (reduce complexity)
    arma::vec sumSigma(o); //there is a sumSigma for each geneSet
    arma::vec finalDof(o);


//need to run the sapply function
    for ( int i=0 ; i < o ; i++) { //running a for loop
        SEXP nn = geneSet[i];
        Rcpp::NumericVector index(nn);
        int p = index.size();
        arma::vec test(p);
//we subset before computing, and use the Rcpp index vector to avoid creating an unsigned vector as armadillo type
        Rcpp::NumericVector sd = SD[index -1]; //converting to 0 based
        Rcpp::NumericVector dof = DOF[index-1];
//fast copy pointer address without data cache copy armadillo variables
        arma::vec asd(sd.begin(),sd.size(),false);
        arma::colvec adof(dof.begin(),dof.size(),false);
        test =(asd%asd)%(adof/(adof-2));
        sumSigma(i) = sqrt(sum(test)); //summing the subsets
        finalDof(i) = floor(min(adof));
    }


    return Rcpp::List::create( Rcpp::Named("SumSigma") = Rcpp::wrap(sumSigma),
                               Rcpp::Named("MinDof") = Rcpp::wrap(finalDof));
}
Exemple #23
0
//' rcpp_trunc_ndist
//'
//' Truncated normal distribution (mean 1, respective upper and lower limits of
//' 0 and 2). Code copied directly from `github.com/mpadge/tnorm`, with the
//' readme of that repo demonstrating the speed advantages of using this rather
//' than pre-existing approaches (the R package `truncnorm`).
//'
//' @param len Number of elements to be simulated
//' @param sd Standard deviation
//'
//' @return A vector of truncated normally distributed values
//'
// [[Rcpp::export]]
Rcpp::NumericVector rcpp_trunc_ndist (int len, double sd)
{
    double tempd;

    // Set up truncated normal distribution
    Rcpp::NumericVector eps (len);

    std::vector <double> z;
    z.resize (0);
    while (z.size () < len)
    {
        eps = Rcpp::rnorm (len, 1.0, sd);
        for (Rcpp::NumericVector::iterator it = eps.begin ();
                it != eps.end (); ++it)
            if (*it >= 0.0 && *it <= 2.0)
                z.push_back (*it);
    }
    z.resize (len);

    std::copy (z.begin (), z.end (), eps.begin ());
    z.resize (0);

    return eps;
}
Exemple #24
0
    double nlmerResp::updateMu(Rcpp::NumericVector const &gamma) throw(std::runtime_error) {
	int n = d_y.size();
#ifdef USE_RCPP_SUGAR
	Rcpp::NumericVector gam = gamma + d_offset;
#else
	NumericVector gam(d_offset.size());
	std::transform(gamma.begin(), gamma.end(), d_offset.begin(),
		       gam.begin(), std::plus<double>());
#endif
	double *gg = gam.begin();

	for (int p = 0; p < d_pnames.size(); p++) {
	    std::string pn(d_pnames[p]);
	    Rcpp::NumericVector pp = d_nlenv.get(pn);
	    std::copy(gg + n * p, gg + n * (p + 1), pp.begin());
	}
	NumericVector rr = d_nlmod.eval(SEXP(d_nlenv));
	if (rr.size() != n)
	    throw std::runtime_error("dimension mismatch");
	std::copy(rr.begin(), rr.end(), d_mu.begin());
	NumericMatrix rrg = rr.attr("gradient");
	std::copy(rrg.begin(), rrg.end(), d_sqrtXwt.begin());
	return updateWrss();
    }
Exemple #25
0
// [[Rcpp::export]]
double trapzRcpp(const Rcpp::NumericVector X, const Rcpp::NumericVector Y){   

  if( Y.size() != X.size()){
    Rcpp::stop("The input Y-grid does not have the same number of points as input X-grid.");
  }
  if(is_sorted(X.begin(),X.end())){
    double trapzsum = 0; 
    for (unsigned int ind = 0; ind !=  X.size()-1; ++ind){
      trapzsum += 0.5 * (X[ind + 1] - X[ind]) *(Y[ind] + Y[ind + 1]); 
    }
    return trapzsum;
  } else {
    Rcpp::stop("The input X-grid is not sorted.");
    return  std::numeric_limits<double>::quiet_NaN();
  }
  return  std::numeric_limits<double>::quiet_NaN();
}
	SEXP conditionalPoissonSecondInclusion(SEXP sizes_sexp, SEXP n_sexp)
	{
	BEGIN_RCPP
		Rcpp::NumericVector sizes = Rcpp::as<Rcpp::NumericVector>(sizes_sexp);
		int n = Rcpp::as<int>(n_sexp);
		conditionalPoissonArgs args;
		args.weights.insert(args.weights.begin(), sizes.begin(), sizes.end());
		args.n = n;

		std::vector<mpfr_class> inclusionProbabilities;
		args.zeroWeights.resize(sizes.size());
		args.deterministicInclusion.resize(sizes.size());
		args.indices.clear();
		for(int i = 0; i != sizes.size(); i++)
		{
			args.zeroWeights[i] = args.deterministicInclusion[i] = false;
			if(sizes[i] < 0 || sizes[i] > 1)
			{
				throw std::runtime_error("Sizes must be values in [0, 1]");
			}
			else if(sizes[i] == 0)
			{
				args.zeroWeights[i] = true;
			}
			else if(sizes[i] == 1)
			{
				args.deterministicInclusion[i] = true;
				args.indices.push_back(i);
			}
		}
		computeExponentialParameters(args);
		conditionalPoissonInclusionProbabilities(args, inclusionProbabilities);
		boost::numeric::ublas::matrix<mpfr_class> secondOrder(sizes.size(), sizes.size());
		conditionalPoissonSecondOrderInclusionProbabilities(args, inclusionProbabilities, secondOrder);
		Rcpp::NumericMatrix result(sizes.size(), sizes.size());
		for(int i = 0; i < sizes.size(); i++)
		{
			for(int j = 0; j < sizes.size(); j++)
			{
				result(i, j) = secondOrder(i, j).convert_to<double>();
			}
		}
		return result;
	END_RCPP
	}
	SEXP conditionalPoissonInclusion(SEXP sizes_sexp, SEXP n_sexp)
	{
	BEGIN_RCPP
		Rcpp::NumericVector sizes = Rcpp::as<Rcpp::NumericVector>(sizes_sexp);
		int n = Rcpp::as<int>(n_sexp);
		conditionalPoissonArgs args;
		args.weights.insert(args.weights.begin(), sizes.begin(), sizes.end());
		args.n = n;

		std::vector<mpfr_class> inclusionProbabilities;
		args.zeroWeights.resize(sizes.size());
		args.deterministicInclusion.resize(sizes.size());
		args.indices.clear();
		for(int i = 0; i != sizes.size(); i++)
		{
			args.zeroWeights[i] = args.deterministicInclusion[i] = false;
			if(sizes[i] < 0 || sizes[i] > 1)
			{
				throw std::runtime_error("Sizes must be values in [0, 1]");
			}
			else if(sizes[i] == 0)
			{
				args.zeroWeights[i] = true;
			}
			else if(sizes[i] == 1)
			{
				args.deterministicInclusion[i] = true;
				args.indices.push_back(i);
			}
		}
		computeExponentialParameters(args);
		conditionalPoissonInclusionProbabilities(args, inclusionProbabilities);
		std::vector<double> inclusionProbabilities_double;
		std::transform(inclusionProbabilities.begin(), inclusionProbabilities.end(), std::back_inserter(inclusionProbabilities_double), [](mpfr_class x){ return x.convert_to<double>(); });
		return Rcpp::wrap(inclusionProbabilities_double);
	END_RCPP
	}
Exemple #28
0
//[[Rcpp::export]]
arma::cube PathDisturb(const arma::vec& start,
                       Rcpp::NumericVector disturb_) {
  // R objects to C++
  const arma::ivec d_dims = disturb_.attr("dim");
  const std::size_t n_dim = d_dims(0);
  const std::size_t n_dec = d_dims(3) + 1;
  const std::size_t n_path = d_dims(2);
  const arma::cube disturb(disturb_.begin(), n_dim, n_dim * n_path, n_dec - 1,
			  false);
  // Simulating the sample paths
  arma::cube path(n_path, n_dim, n_dec);
  // Assign starting values
  for (std::size_t ii = 0; ii < n_dim; ii++) {
    path.slice(0).col(ii).fill(start(ii));
  }
  // Disturb the paths
  for (std::size_t pp = 0; pp < n_path; pp++) {
    for (std::size_t tt = 1; tt < n_dec; tt++) {
      path.slice(tt).row(pp) = path.slice(tt - 1).row(pp) *
          arma::trans(disturb.slice(tt - 1).cols(n_dim * pp, n_dim * (pp + 1) - 1));
    }
  }
  return path;
}
Exemple #29
0
   void densePred::setCoef0(const Rcpp::NumericVector& cc)
	throw (std::runtime_error) {
	if (cc.size() != d_coef0.size())
	    throw std::runtime_error("size mismatch in setCoef0");
	std::copy(cc.begin(), cc.end(), d_coef0.begin());
    }
Exemple #30
0
void vec_insert( vec* obj, int position, Rcpp::NumericVector data) {
    vec::iterator it = obj->begin() + position;
    obj->insert( it, data.begin(), data.end() );
}