//' 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); } } }
// 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); }
// 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; }
// [[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; }
// 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; }
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); }
//' 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; }
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 }
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(); }
// [[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; }
// 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); }
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]); } } }
// 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); }
// [[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)); }
// 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); }
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(); }
/** * 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)); }
//' 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; }
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(); }
// [[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 }
//[[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; }
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()); }
void vec_insert( vec* obj, int position, Rcpp::NumericVector data) { vec::iterator it = obj->begin() + position; obj->insert( it, data.begin(), data.end() ); }