// [[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]] Rcpp::NumericMatrix rcpp_sweep_(Rcpp::NumericMatrix x, Rcpp::NumericVector vec) { Rcpp::NumericMatrix ret(x.nrow(), x.ncol()); #pragma omp parallel for default(shared) for (int j=0; j<x.ncol(); j++) { #pragma omp simd for (int i=0; i<x.nrow(); i++) ret(i, j) = x(i, j) - vec(i); } return ret; }
std::vector<std::vector<float> > matrix_to_array_v(Rcpp::NumericMatrix& mat) { std::vector<std::vector<float> > v; if(!mat.ncol() || !mat.nrow()) return(v); v.resize(mat.nrow()); std::vector<float> v_row(mat.ncol()); // = new float[ mat.ncol() * mat.nrow() ]; for(unsigned int i=0; i < (unsigned int)mat.nrow(); ++i){ for(unsigned int j=0; j < (unsigned int)mat.ncol(); ++j){ v_row[j] = (float)mat(i, j); } v[i] = v_row; } return(v); }
static double bic_linear(Rcpp::NumericMatrix X, Rcpp::NumericVector y, Rcpp::NumericMatrix beta_new, double eps, Rcpp::IntegerVector nk) { int n_tot = X.nrow(); int p = X.ncol(); int K = nk.size(); /*calculate SSe*/ double SSe = 0.0; int idx = 0; for (int k = 0; k < K; k++) { int n = nk[k]; for (int i = 0; i < n; i++) { double Xrow_betacol = 0.0; for (int j = 0; j < p; j++) { Xrow_betacol += elem(X, idx+i, j) * elem(beta_new, j, k); } SSe += pow(y[idx+i] - Xrow_betacol, 2); } idx += n; } double ll = -n_tot / 2.0 * (log(SSe) - log(n_tot) + log(2.0 * M_PI) + 1); double bic = -2 * ll + df(beta_new, eps) * log(n_tot); return bic; }
static Rcpp::IntegerVector nz_vec(Rcpp::NumericMatrix alpha_new, Rcpp::NumericMatrix eta_new, Rcpp::NumericVector d_new, double eps) { int K = alpha_new.ncol(); int p = alpha_new.nrow(); int L = eta_new.nrow(); Rcpp::IntegerVector result(p*K + L*K + L); for (int i = 0; i < p*K; i++) { result[i] = nz(alpha_new[i],eps); } for (int i = 0; i < L*K; i++) { result[p*K + i] = nz(eta_new[i],eps); } for (int i = 0; i < L; i++) { result[p*K + L*K + i] = nz(d_new[i],eps); } return result; }
static Rcpp::NumericMatrix x_tilde_3(Rcpp::NumericMatrix X, Rcpp::IntegerVector nk, Rcpp::IntegerMatrix groups, Rcpp::NumericMatrix alpha_new, Rcpp::NumericVector d_new) { int K = nk.size(); int n_tot = X.nrow(); int p = X.ncol(); int L = groups.ncol(); Rcpp::NumericMatrix result(n_tot, L * K); int idx = 0; for (int k = 0; k < K; k++) { int n = nk[k]; for (int l = 0; l < L; l++) { for (int i = 0; i < n; i++) { double sum = 0.0; for (int j = 0; j < p; j++) { if (elem(groups, j, l)) { sum += elem(X, idx + i, j) * elem(alpha_new, j, k); } } elem(result, idx + i, L * k + l) = d_new[l] * sum; } } idx += n; } return result; }
static double bic_logistic(Rcpp::NumericMatrix X, Rcpp::NumericVector y, Rcpp::NumericMatrix beta_new, double eps, Rcpp::IntegerVector nk) { int n_tot = X.nrow(); int p = X.ncol(); int K = nk.size(); int idx = 0; double ll = 0.0; for (int k = 0; k < K; k++) { int n = nk[k]; for (int i = 0; i < n; i++) { double lp = 0.0; for (int j = 0; j < p; j++) { lp += elem(X, idx+i, j) * elem(beta_new, j, k); } ll += y[idx+i] * lp - log(1.0 + exp(lp)); } idx += n; } double bic = -2.0 * ll + df(beta_new, eps) * log(n_tot); return bic; }
//' Marginal correlation matrix //' //' Various workhorse functions to compute the marginal (or unconditional) //' correlations (and cross-correlation) estimates efficiently. //' They are (almost) //' equivalent implementations of \code{\link[stats]{cor}} in Rcpp, //' RcppArmadillo, and RcppEigen. //' //' @rdname corFamily //' @aliases corFamily //' corRcpp xcorRcpp corArma xcorArma corEigen xcorEigen //' @param X A numeric matrix. //' @param Y A numeric matrix of compatible dimension with the \code{X}, i.e. //' \code{nrow(X)} equals \code{nrow(Y)}. //' @return //' The \code{corXX} family returns a numeric correlation matrix of size //' \code{ncol(X)} times \code{ncol(X)}. //' //' The \code{xcorXX} family returns a numeric cross-correlation matrix //' of size \code{ncol(X)} times \code{ncol(Y)}. //' @details //' Functions almost like \code{\link{cor}}. //' For the \code{xcorXX} functions, the \code{i}'th and \code{j}'th //' entry of the output matrix is the correlation between \code{X[i, ]} and //' \code{X[j, ]}. //' Likewise, for the \code{xcorXX} functions, the \code{i}'th and //' \code{j}'th entry of the output is the correlation between \code{X[i, ]} //' and \code{Y[j, ]}. //' @note //' \code{NA}s in \code{X} or \code{Y} will yield \code{NA}s in the correlation matrix. //' This also includes the diagonal unlike the behavior of //' \code{\link[stats]{cor}}. //' @author Anders Ellern Bilgrau <anders.ellern.bilgrau (at) gmail.com> //' @export // [[Rcpp::export]] Rcpp::NumericMatrix corRcpp(Rcpp::NumericMatrix & X) { const int m = X.ncol(); const int n = X.nrow(); // Centering the matrix X = centerNumericMatrix(X); Rcpp::NumericMatrix cor(m, m); // Degenerate case if (n == 0) { std::fill(cor.begin(), cor.end(), Rcpp::NumericVector::get_na()); return cor; } // Compute 1 over the sample standard deviation Rcpp::NumericVector inv_sqrt_ss(m); for (int i = 0; i < m; ++i) { inv_sqrt_ss(i) = 1/sqrt(Rcpp::sum(X(Rcpp::_, i)*X(Rcpp::_, i))); } // Computing the correlation matrix for (int i = 0; i < m; ++i) { for (int j = 0; j <= i; ++j) { cor(i, j) = Rcpp::sum(X(Rcpp::_,i)*X(Rcpp::_,j)) * inv_sqrt_ss(i) * inv_sqrt_ss(j); cor(j, i) = cor(i, j); } } return cor; }
///******************************************************************** ///** cdm_rcpp_irt_classify_individuals // [[Rcpp::export]] Rcpp::List cdm_rcpp_irt_classify_individuals( Rcpp::NumericMatrix like ) { int N = like.nrow(); int TP = like.ncol(); Rcpp::IntegerVector class_index(N); Rcpp::NumericVector class_maxval(N); double val=0; int ind=0; for (int nn=0; nn<N; nn++){ val=0; ind=0; for (int tt=0; tt<TP; tt++){ if ( like(nn,tt) > val ){ val = like(nn,tt); ind = tt; } } class_index[nn] = ind + 1; class_maxval[nn] = val; } //---- OUTPUT: return Rcpp::List::create( Rcpp::Named("class_index") = class_index, Rcpp::Named("class_maxval") = class_maxval ); }
// [[Rcpp::export]] Rcpp::NumericMatrix update_sigma2_batch(Rcpp::S4 xmod){ Rcpp::RNGScope scope; // get model Rcpp::S4 model(xmod); // get parameter estimates Rcpp::NumericMatrix theta = model.slot("theta"); Rcpp::IntegerVector z = model.slot("z"); double nu_0 = model.slot("nu.0"); double sigma2_0 = model.slot("sigma2.0"); // get data and size attributes Rcpp::NumericVector x = model.slot("data"); int n = x.size(); int K = theta.ncol(); int B = theta.nrow(); //IntegerVector nn = model.slot("zfreq"); // get batch info Rcpp::NumericMatrix tabz = tableBatchZ(xmod); Rcpp::IntegerVector batch = model.slot("batch"); Rcpp::IntegerVector ub = uniqueBatch(batch); Rcpp::NumericMatrix ss(B, K); for (int i = 0; i < n; ++i) { for (int b = 0; b < B; ++b) { if (batch[i] != ub[b]) { continue; } for (int k = 0; k < K; ++k){ if (z[i] == k+1){ ss(b, k) += pow(x[i] - theta(b, k), 2); } } } } //NumericMatrix sigma2_nh(B, K); double shape; double rate; double sigma2_nh; double nu_n; Rcpp::NumericMatrix sigma2_tilde(B, K); Rcpp::NumericMatrix sigma2_(B, K); for (int b = 0; b < B; ++b) { for (int k = 0; k < K; ++k) { nu_n = nu_0 + tabz(b, k); sigma2_nh = 1.0/nu_n*(nu_0*sigma2_0 + ss(b, k)); shape = 0.5 * nu_n; rate = shape * sigma2_nh; sigma2_tilde(b, k) = Rcpp::as<double>(rgamma(1, shape, 1.0/rate)); sigma2_(b, k) = 1.0 / sigma2_tilde(b, k); } } return sigma2_; }
/** * Update V, Vtr and fac * * Note: May want to update fac in a separate operation. For the * fixed-effects modules this will update the factor twice because * it is separately updated in updateRzxRx. * * @param Xwt square root of the weights for the model matrices * @param wtres weighted residuals */ void sPredModule::reweight(Rcpp::NumericMatrix const& Xwt, Rcpp::NumericVector const& wtres) throw(std::runtime_error) { if (d_coef.size() == 0) return; double one = 1., zero = 0.; int Wnc = Xwt.ncol();//, Wnr = Xwt.nrow(), // Xnc = d_X.ncol, Xnr = d_X.nrow; if ((Xwt.rows() * Xwt.cols()) != (int)d_X.nrow) throw std::runtime_error("dimension mismatch"); // Rf_error("%s: dimension mismatch %s(%d,%d), %s(%d,%d)", // "deFeMod::reweight", "X", Xnr, Xnc, // "Xwt", Wnr, Wnc); if (Wnc == 1) { if (d_V) M_cholmod_free_sparse(&d_V, &c); d_V = M_cholmod_copy_sparse(&d_X, &c); chmDn csqrtX(Xwt); M_cholmod_scale(&csqrtX, CHOLMOD_ROW, d_V, &c); } else throw runtime_error("sPredModule::reweight: multiple columns in Xwt"); // FIXME write this combination using the triplet representation chmDn cVtr(d_Vtr); const chmDn cwtres(wtres); M_cholmod_sdmult(d_V, 'T', &one, &zero, &cwtres, &cVtr, &c); CHM_SP Vt = M_cholmod_transpose(d_V, 1/*values*/, &c); d_fac.update(*Vt); M_cholmod_free_sparse(&Vt, &c); }
static Rcpp::NumericMatrix x_tilde_2(Rcpp::NumericMatrix X, Rcpp::IntegerVector nk, Rcpp::IntegerMatrix groups, Rcpp::NumericMatrix alpha_new, Rcpp::NumericMatrix eta_cur) { int K = nk.size(); int n_tot = X.nrow(); int p = X.ncol(); int L = groups.ncol(); Rcpp::NumericMatrix result(n_tot, L); for (int l = 0; l < L; l++) { int k = -1; int n = 0; for (int i = 0; i < n_tot; i++) { if (i == n){ k +=1; n += nk[k]; } double sum = 0.0; for (int j = 0; j < p; j++) { if (elem(groups, j, l)) { sum += elem(X, i, j) * elem(alpha_new, j, k); } } elem(result, i, l) = elem(eta_cur, l, k) * sum; } } return result; }
///******************************************************************** ///** scale2_NA_C // [[Rcpp::export]] Rcpp::NumericMatrix scale2_NA_C( Rcpp::NumericMatrix x ) { int n = x.nrow(); int p = x.ncol(); Rcpp::NumericMatrix y(n,p); double mvv=0; double sdvv=0; double nvv=0; double eps_add = 1e-10; for (int vv=0;vv<p;vv++){ mvv=0; sdvv=0; nvv=0; for (int ii=0;ii<n;ii++){ if (! R_IsNA(x(ii,vv)) ) { mvv += x(ii,vv); sdvv += std::pow( x(ii,vv), 2.0 ); nvv ++; } } mvv = mvv / nvv; sdvv = std::sqrt( ( sdvv - nvv * mvv*mvv )/(nvv - 1.0 ) ); // define standardization y(_,vv) = ( x(_,vv) - mvv ) / ( sdvv + eps_add ); } //--- output return y; }
//' Check whether there are any non-finite values in a matrix //' //' The C++ functions will not work with NA values, and the calculation of the //' summary profile will take a long time to run before crashing. //' //' @param matPtr matrix to check. //' //' @return //' Throws an error if any \code{NA}, \code{NaN}, \code{Inf}, or \code{-Inf} //' values are found, otherwise returns silently. //' // [[Rcpp::export]] void CheckFinite(Rcpp::NumericMatrix matPtr) { arma::mat mat = arma::mat(matPtr.begin(), matPtr.nrow(), matPtr.ncol(), false, true); arma::uvec nonFiniteIdx = arma::find_nonfinite(mat); if (nonFiniteIdx.n_elem > 0) { throw Rcpp::exception("matrices cannot have non-finite or missing values"); } }
void ScoreGaussL0PenScatter::setData(Rcpp::List& data) { std::vector<int>::iterator vi; //uint i; // Cast preprocessed data from R list dout.level(2) << "Casting preprocessed data...\n"; _dataCount = Rcpp::as<std::vector<int> >(data["data.count"]); dout.level(3) << "# samples per vertex: " << _dataCount << "\n"; _totalDataCount = Rcpp::as<uint>(data["total.data.count"]); dout.level(3) << "Total # samples: " << _totalDataCount << "\n"; Rcpp::List scatter = data["scatter"]; Rcpp::NumericMatrix scatterMat; _disjointScatterMatrices.resize(scatter.size()); dout.level(3) << "# disjoint scatter matrices: " << scatter.size() << "\n"; for (R_len_t i = 0; i < scatter.size(); ++i) { scatterMat = Rcpp::NumericMatrix((SEXP)(scatter[i])); _disjointScatterMatrices[i] = arma::mat(scatterMat.begin(), scatterMat.nrow(), scatterMat.ncol(), false); } // Cast index of scatter matrices, adjust R indexing convention to C++ std::vector<int> scatterIndex = Rcpp::as<std::vector<int> >(data["scatter.index"]); for (std::size_t i = 0; i < scatterIndex.size(); ++i) _scatterMatrices[i] = &(_disjointScatterMatrices[scatterIndex[i] - 1]); // Cast lambda: penalty constant _lambda = Rcpp::as<double>(data["lambda"]); dout.level(3) << "Penalty parameter lambda: " << _lambda << "\n"; // Check whether an intercept should be calculated _allowIntercept = Rcpp::as<bool>(data["intercept"]); dout.level(3) << "Include intercept: " << _allowIntercept << "\n"; }
static Rcpp::NumericMatrix x_tilde(Rcpp::NumericMatrix X, Rcpp::IntegerVector nk, Rcpp::IntegerMatrix groups, Rcpp::NumericVector d_cur, Rcpp::NumericMatrix eta_cur) { int K = nk.size(); int n_tot = X.nrow(); int p = X.ncol(); int L = groups.ncol(); Rcpp::NumericMatrix result(n_tot, p * K); int idx = 0; for (int k = 0; k < K; k++) { int n = nk[k]; for (int j = 0; j < p; j++) { //calculate sum for column j double sum = 0.0; for (int l = 0; l < L; l++) { if (elem(groups, j, l)) { sum += d_cur[l] * elem(eta_cur, l, k); } } //multiply column j in submatrix k of X with sum for (int i = 0; i < n; i++) { elem(result, idx + i, p * k + j) = elem(X, idx + i, j) * sum; } } idx += n; } return result; }
//' @title Calculating validation scores between two adjacency matrices //' //' @description //' This function calculates the validation scores between two adjacency matrices. //' //' @param inf_mat matrix. It should be adjacency matrix of inferred network. //' @param true_mat matrix. It should be adjacency matrix of true network. // [[Rcpp::export]] Rcpp::NumericVector rcpp_validate(Rcpp::NumericMatrix inf_mat, Rcpp::NumericMatrix true_mat) { if(inf_mat.ncol() != true_mat.ncol()) { throw std::invalid_argument( "Two input matrices should have the same number of columns." ); } if(inf_mat.nrow() != true_mat.nrow()) { throw std::invalid_argument( "Two input matrices should have the same number of rows." ); } int tp=0; int tn=0; int fp=0; int fn=0; for(signed int i=0; i<inf_mat.nrow(); i++) { //Convert R objects into C++ objects. Rcpp::NumericVector xr = inf_mat.row(i); Rcpp::NumericVector yr = true_mat.row(i); std::vector<int> x = Rcpp::as<std::vector <int> >(xr); std::vector<int> y = Rcpp::as<std::vector <int> >(yr); std::vector<int> z; //Calculate the frequency of numbers. //tp=true positive [1,1], tn=true negative [0,0], fp=false positive [1,0], fn=false negative [0,1]. for(unsigned int k=0; k<x.size(); k++) { z.push_back(x[k] + y[k]); //Calculate the summation of x and y between each element. if(z[k] == 2) { tp += 1; } else if(z[k] == 0) { tn += 1; } else if(z[k] == 1) { if(x[k] == 0) { fp += 1; } else { fn += 1; } } else { throw std::invalid_argument("Error in calculating the contigency table."); } } } //std::vector<int> output{tp, tn, fp, fn}; c++11 only int tmp_arr[4] = {tp, tn, fp, fn}; std::vector<int> output(&tmp_arr[0], &tmp_arr[0]+4); return Rcpp::wrap(output); }
// This calculates lambda from a lookup table index by transition (row) and rounded quality (col) double compute_lambda(Raw *raw, Sub *sub, Rcpp::NumericMatrix errMat, bool use_quals) { // use_quals does nothing in this function, just here for backwards compatability for now int s, pos0, pos1, nti0, nti1, len1, ncol; double lambda; float prefactor, fqmin; int tvec[SEQLEN]; int qind[SEQLEN]; if(!sub) { // NULL Sub, outside Kmer threshold return 0.0; } // Make vector that indexes as integers the transitions at each position in seq1 // Index is 0: exclude, 1: A->A, 2: A->C, ..., 5: C->A, ... len1 = raw->length; ncol = errMat.ncol(); prefactor = ((float) (ncol-1))/((float) QMAX-QMIN); fqmin = (float) QMIN; for(pos1=0;pos1<len1;pos1++) { nti1 = ((int) raw->seq[pos1]) - 1; if(nti1 == 0 || nti1 == 1 || nti1 == 2 || nti1 == 3) { tvec[pos1] = nti1*4 + nti1; } else { Rcpp::stop("Error: Can't handle non ACGT sequences in CL3."); } if(raw->qual) { // Turn quality into the index in the array qind[pos1] = round(prefactor * (raw->qual[pos1] - fqmin)); } else { qind[pos1] = 0; } if( qind[pos1] > (ncol-1) ) { Rcpp::stop("Error: rounded quality exceeded err lookup table."); } } // Now fix the ones where subs occurred for(s=0;s<sub->nsubs;s++) { pos0 = sub->pos[s]; if(pos0 < 0 || pos0 >= len1) { Rcpp::stop("CL: Bad pos0."); } pos1 = sub->map[sub->pos[s]]; if(pos1 < 0 || pos1 >= len1) { Rcpp::stop("CL: Bad pos1."); } nti0 = ((int) sub->nt0[s]) - 1; nti1 = ((int) sub->nt1[s]) - 1; tvec[pos1] = nti0*4 + nti1; } // And calculate lambda lambda = 1.0; for(pos1=0;pos1<len1;pos1++) { lambda = lambda * errMat(tvec[pos1], qind[pos1]); } if(lambda < 0 || lambda > 1) { Rcpp::stop("Bad lambda."); } return lambda; }
densePred::densePred(Rcpp::NumericMatrix x, Rcpp::NumericVector coef0) throw (std::runtime_error) : predMod(coef0), d_X(x), a_X(x.begin(), x.nrow(), x.ncol(), false, true) { if (d_coef0.size() != d_X.ncol()) throw std::runtime_error("length(coef0) != ncol(X)"); }
//[[Rcpp::export]] Rcpp::NumericMatrix ZERO(Rcpp::NumericMatrix x) { int i=0, j=0; for(i=0; i < x.ncol(); i++) { for(j=0; j < x.nrow(); j++) { x(i,j) = 0; } } return(x); }
static int df(Rcpp::NumericMatrix beta_new, double eps) { int result = 0; int n = beta_new.nrow() * beta_new.ncol(); for(int i=0; i < n; i++){ result += nz(beta_new[i],eps); } return result; }
// 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; }
static void print(Rcpp::NumericMatrix A) { for (int i = 0; i < A.nrow(); i++) { for (int j = 0; j < A.ncol(); j++) { printf("%9f ", elem(A, i, j)); } putchar('\n'); } }
//[[Rcpp::export]] void decorr(Rcpp::NumericMatrix x) { unsigned int i = 1, j=1, n=x.nrow(); if(n != x.ncol()) Rcpp::stop("matrix is not square"); for(i=0; i < n; i++) { for(j=0; j < n; j++) { if(j!=i) x(i,j) = x(i,j)*sqrt(x(i,i)*x(j,j)); } } }
// [[Rcpp::export]] Rcpp::NumericMatrix testColPost(Rcpp::NumericMatrix post, Rcpp::List m2u, int nthreads){ Rcpp::IntegerVector values = Rcpp::as<Rcpp::IntegerVector>(m2u["values"]); Rcpp::IntegerVector map = Rcpp::as<Rcpp::IntegerVector>(m2u["map"]); if (post.ncol() != map.length()) Rcpp::stop("posteriors doesn't match with m2u"); Rcpp::NumericMatrix smallerPost(post.nrow(), values.length()); Vec<double> foo; NMPreproc preproc(asVec(values), asVec(map), foo); collapsePosteriors_core(asMat(smallerPost), asMat(post), preproc); return smallerPost; }
static Rcpp::IntegerMatrix nz(Rcpp::NumericMatrix m, double eps) { int nr = m.nrow(); int nc = m.ncol(); Rcpp::IntegerMatrix result(nr, nc); for(int i=0; i < nr*nc; i++){ result[i] = nz(m[i],eps); } return result; }
// 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)); }
///******************************************************************** ///** tam_rcpp_irt_likelihood_cfa // [[Rcpp::export]] Rcpp::List tam_rcpp_irt_likelihood_cfa( Rcpp::NumericMatrix data, Rcpp::NumericVector nu, Rcpp::NumericMatrix psi, Rcpp::NumericMatrix L, Rcpp::NumericMatrix theta ) { int N = data.nrow(); int I = data.ncol(); int D = L.ncol(); int TP= theta.nrow(); Rcpp::NumericMatrix hwt(N,TP); std::fill( hwt.begin(), hwt.end(), 1 ); double term=0; double val=0; double sdii=0; for (int tt=0;tt<TP;tt++){ for (int ii=0;ii<I;ii++){ term = nu[ii]; for (int dd=0; dd < D; dd++){ term += L(ii,dd) * theta(tt,dd); } sdii = sqrt( psi(ii,ii) ); for (int nn=0;nn<N;nn++){ if ( ! R_IsNA( data(nn,ii) ) ){ val = ::Rf_dnorm4( data(nn,ii), term, sdii, false ); hwt(nn,tt) = hwt(nn,tt) * val; } // end if not missing } // end nn } // end ii } // end tt //************************************************* // OUTPUT return Rcpp::List::create( Rcpp::Named("hwt") = hwt, Rcpp::Named("N") = N, Rcpp::Named("I") = I, Rcpp::Named("TP")= TP, Rcpp::Named("D") = D ); }
void sampleRho(Rcpp::NumericVector& rho, Rcpp::NumericMatrix& A, arma::mat A_restrict, double rhoa, double rhob){ int k = A.ncol(); int p = A.nrow(); arma::rowvec A_maxnnz_col = arma::sum(A_restrict, 0); for (int i=0; i<k; i++) { NumericMatrix::Column col = A.column(i) ; NumericVector As = ifelse(abs(col)<1e-10, 0.0, 1.0); double nnz = std::accumulate(As.begin(), As.end(), 0.0); double maxnnz = A_maxnnz_col(i); rho(i) = Rf_rbeta(rhoa + nnz, rhob + maxnnz-nnz); } }