// [[Rcpp::export]] NumericVector fstatsC(NumericMatrix pairMat, NumericMatrix mod, NumericMatrix mod0, NumericVector outcome) { int nrow = pairMat.nrow(); int ncol = pairMat.ncol(); double ss, ss0; int df0 = mod0.ncol(); int df = df0+1; // alternative model always has +1 column arma::mat modc(mod.begin(), mod.nrow(), mod.ncol(), false); arma::mat mod0c(mod0.begin(), mod0.nrow(), mod0.ncol(), false); arma::colvec outcomec(outcome.begin(), outcome.size(), false); arma::vec fstats(nrow); arma::vec res = arma::zeros<arma::vec>(outcome.size()); arma::vec res0 = arma::zeros<arma::vec>(outcome.size()); try{ res0 = outcomec - mod0c*arma::solve(mod0c, outcomec); // The residual for the null model remains the same ss0 = arma::as_scalar(arma::trans(res0)*res0); } catch(std::exception &ex) { stop("WTF???"); } for(int i=0; i < nrow; i++){ // loop through all rows in pairMat //modc.insert_cols(mod.ncol(), pairMat(i,_)); can try this later, it's not working for(int j=0; j < pairMat.ncol(); j++){ // this loop is for copying the ith row of pairMat into the last column of modc modc(j,modc.n_cols-1) = pairMat(i,j); // Here we add the current row to the model } try{ res = outcomec - modc*arma::solve(modc, outcomec); // Calculate the residual ss = arma::as_scalar(arma::trans(res)*res); fstats(i) = ((ss0 - ss)/(df-df0))/(ss/(ncol-df)); } catch(std::exception &ex) { fstats(i) = NA_REAL; } } return Rcpp::wrap(fstats); }
// [[Rcpp::export("multiKernel_cpp")]] SEXP multiKernel(NumericMatrix Yr, NumericMatrix Zr, NumericMatrix Kr, double tau) { int n = Yr.nrow(), p = Yr.ncol(), q = Zr.ncol(); arma::mat K(Kr.begin(), n, n, false); // reuses memory and avoids extra copy arma::mat Y(Yr.begin(), n, p, false); arma::mat Z(Zr.begin(), n, q, false); // Initialize matrices arma::vec tuning_vect(n); tuning_vect.fill(tau); arma::mat tuning_mat(n, n, fill::zeros); tuning_mat.diag() = tuning_vect; arma::mat weight_mat = inv(K + tuning_mat); arma::mat B = inv(trans(Z) * weight_mat * Z) * trans(Z) * weight_mat * Y; arma::mat alpha_mat = weight_mat * (Y - Z * B); double newLS = computeLeastSq(Y, K, alpha_mat, Z, B); double BIC = 2 * newLS + log(n) * as_scalar(accu(B > 0) + accu(alpha_mat > 0)); return Rcpp::List::create( Rcpp::Named("alpha") = alpha_mat, Rcpp::Named("B") = B, Rcpp::Named("LS") = newLS, Rcpp::Named("BIC") = BIC); }
NumericVector logLikMixHMM(NumericVector transitionMatrix, NumericVector emissionArray, NumericVector initialProbs, IntegerVector obsArray, NumericMatrix coefs, NumericMatrix X_, IntegerVector numberOfStates) { IntegerVector eDims = emissionArray.attr("dim"); //m,p,r IntegerVector oDims = obsArray.attr("dim"); //k,n,r int q = coefs.nrow(); arma::mat coef(coefs.begin(),q,coefs.ncol()); coef.col(0).zeros(); arma::mat X(X_.begin(),oDims[0],q); arma::mat lweights = exp(X*coef).t(); if(!lweights.is_finite()){ return wrap(-std::numeric_limits<double>::max()); } lweights.each_row() /= sum(lweights,0); arma::colvec init(initialProbs.begin(),eDims[0], true); arma::mat transition(transitionMatrix.begin(),eDims[0],eDims[0], true); arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], true); arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false); arma::vec alpha(eDims[0]); NumericVector ll(oDims[0]); double tmp; arma::vec initk(eDims[0]); for(int k = 0; k < oDims[0]; k++){ initk = init % reparma(lweights.col(k),numberOfStates); for(int i=0; i < eDims[0]; i++){ alpha(i) = initk(i); for(int r = 0; r < oDims[2]; r++){ alpha(i) *= emission(i,obs(k,0,r),r); } } tmp = sum(alpha); ll(k) = log(tmp); alpha /= tmp; arma::vec alphatmp(eDims[0]); for(int t = 1; t < oDims[1]; t++){ for(int i = 0; i < eDims[0]; i++){ alphatmp(i) = arma::dot(transition.col(i), alpha); for(int r = 0; r < oDims[2]; r++){ alphatmp(i) *= emission(i,obs(k,t,r),r); } } tmp = sum(alphatmp); ll(k) += log(tmp); alpha = alphatmp/tmp; } } return ll; }
//' Fast computation of trace of matrix product //' //' @description Fast computation of the trace of the matrix product trace(t(A) %*% B) //' @param A A matrix with dimensions n*k. //' @param B A matrix with dimenions n*k. //' @return The trace of the matrix product //' @author Claus Ekstrom <claus@@rprimer.dk> //' @examples //' //' A <- matrix(1:12, ncol=3) //' tracemp(A, A) //' //' @export // [[Rcpp::export]] double tracemp(NumericMatrix A, NumericMatrix B) { if ((A.nrow() != B.nrow()) || (A.ncol() != B.ncol())) Rcpp::stop("the two matrices must have the same dimensions"); arma::mat X(A.begin(), A.nrow(), A.ncol(), false); arma::mat Y(B.begin(), B.nrow(), B.ncol(), false); double res = arma::as_scalar(accu(X % Y)); return res; }
//' Apply crossprod and colSums //' //' @description Fast computation of crossprod(colSums(X),Y) //' @param X A matrix with dimensions k*n. Hence the result of \code{colSums(X)} has length n. //' @param Y A matrix with dimenions n*m. Can be a matrix with dimension m*n but then \code{transposeY} should be \code{TRUE}. //' @param transposeY Logical. If \code{TRUE} transpose Y before matrix multiplication. //' @return A vector of length m. //' @author Thomas Alexander Gerds <tag@@biostat.ku.dk> //' @examples //' x <- matrix(1:8,ncol=2) //' y <- matrix(1:16,ncol=8) //' colSumsCrossprod(x,y,0) //' //' x <- matrix(1:8,ncol=2) //' y <- matrix(1:16,ncol=2) //' colSumsCrossprod(x,y,1) //' @export // [[Rcpp::export]] NumericMatrix colSumsCrossprod(NumericMatrix X, NumericMatrix Y, bool transposeY){ arma::mat A(X.begin(), X.nrow(), X.ncol(), false); arma::mat B(Y.begin(), Y.nrow(), Y.ncol(), false); arma::rowvec result; // result of colSums(A) has to be a matrix // with one row and as many columns as B has rows if (transposeY) result = arma::sum(A,0)*B.t(); else result = arma::sum(A,0)*B; return wrap(result); }
//--------------------------------------------------------------------- // //--------------------------------------------------------------------- // [[Rcpp::export]] void numerator_trick(NumericMatrix A, NumericMatrix B) { arma::mat aA(A.begin(), A.nrow(), A.ncol(), false); arma::mat aB(B.begin(), B.nrow(), B.ncol(), false); arma::mat numerator_mat = arma::conv2(aA,arma::fliplr(arma::flipud((aB)))); arma::cx_mat res = arma::ifft2(arma::fft2(aA) % arma::fft2(arma::fliplr(arma::flipud(aB)))); res.print(); numerator_mat.print(); //return numerator_mat; }
//' Apply crossprod and rowSums //' //' @description Fast computation of crossprod(rowSums(X),Y) //' @param X A matrix with dimensions n*k. Hence the result of \code{rowSums(X)} has length n. //' @param Y A matrix with dimenions n*m. Can be a matrix with dimension m*n but then \code{transposeY} should be \code{TRUE}. //' @param transposeY Logical. If \code{TRUE} transpose Y before matrix multiplication. //' @return A vector of length m. //' @author Thomas Alexander Gerds <tag@@biostat.ku.dk> //' @examples //' x <- matrix(1:10,nrow=5) //' y <- matrix(1:20,ncol=4) //' rowSumsCrossprod(x,y,0) //' //' x <- matrix(1:10,nrow=5) //' y <- matrix(1:20,ncol=5) //' rowSumsCrossprod(x,y,1) //' @export // [[Rcpp::export]] NumericMatrix rowSumsCrossprod(NumericMatrix X, NumericMatrix Y, bool transposeY){ arma::mat A(X.begin(), X.nrow(), X.ncol(), false); arma::mat B(Y.begin(), Y.nrow(), Y.ncol(), false); arma::rowvec result; // result of colSums(A) has to be a matrix // with one row and as many columns as B has rows // since sum(A,1) is a matrix with one column // we transpose before multiplication if (transposeY) result = arma::sum(A,1).t()*B.t(); else result = arma::sum(A,1).t()*B; return wrap(result); }
// [[Rcpp::export]] NumericMatrix residLm(NumericMatrix Yr, NumericMatrix Xr) { int nX = Xr.nrow(), nY = Yr.nrow(); arma::mat Y(Yr.begin(), nY, nX, false); // reuses memory and avoids extra copy arma::mat X(Xr.begin(), nX, 2, false); arma::mat resid(nX,nY); arma::colvec y; for(int i = 0; i < nY; i++){ y = Y.row(i).t(); resid.col(i) = y - X*arma::solve(X, y); } return wrap(resid.t()); }
// [[Rcpp::export("multiKernel_noCon_cpp")]] SEXP multiKernel_noCon(NumericMatrix Yr, NumericMatrix Kr, double tau) { int n = Yr.nrow(), p = Yr.ncol(); arma::mat K(Kr.begin(), n, n, false); // reuses memory and avoids extra copy arma::mat Y(Yr.begin(), n, p, false); // Initialize matrices arma::vec tuning_vect(n); tuning_vect.fill(tau); arma::mat tuning_mat(n, n, fill::zeros); tuning_mat.diag() = tuning_vect; arma::mat alpha_mat = inv(K + tuning_mat) * Y; return Rcpp::List::create(Rcpp::Named("alpha") = alpha_mat); }
// [[Rcpp::export]] NumericMatrix CPP_similarity_to_distance(NumericMatrix M, int opcode, double tol, bool duplicate = true) { if (!R_FINITE(opcode) || opcode < 0 || opcode > 0) stop("internal error -- invalid transformation method code"); unsigned int n_items = M.length(); NumericMatrix res = M; if (duplicate) res = clone(M); NumericMatrix::iterator _res = res.begin(); unsigned int n_clamped = 0; for (unsigned int i = 0; i < n_items; i++) { double x = _res[i]; switch (opcode) { case 0: if (x < -(1-tol)) { if (x < -(1+tol)) n_clamped++; x = -1; } else if (x > (1-tol)) { if (x > (1+tol)) n_clamped++; x = 1; } x = acos(x) * 180 / M_PI; break; } _res[i] = x; } if (n_clamped > 0) Rf_warning("angular distance may be inaccurate (some cosine values out of range)"); return res; }
// [[Rcpp::export]] NumericMatrix CPP_dsm_score_dense(NumericMatrix f, NumericVector f1, NumericVector f2, double N, int am_code, int sparse, int transform_code) { if (am_code < 0 || am_code >= am_table_entries) stop("internal error -- invalid AM code"); am_func AM = am_table[am_code]; /* selected association measure */ int nr = f.nrow(), nc = f.ncol(); if (am_code != 0 && (nr != f1.size() || nc != f2.size())) stop("internal error -- marginal vectors f1 and f2 not conformable with matrix f"); NumericMatrix scores(nr, nc); NumericMatrix::iterator _f = f.begin(); NumericVector::iterator _f1 = f1.begin(); NumericVector::iterator _f2 = f2.begin(); NumericMatrix::iterator _scores = scores.begin(); int i = 0; for (int col = 0; col < nc; col++) { for (int row = 0; row < nr; row++) { /* frequeny measure (am_code == 0) is a special case, since marginals may not be available (in "reweight" mode) */ double score = (am_code == 0) ? _f[i] : AM(_f[i], _f1[row], _f2[col], N, sparse); _scores[i] = (transform_code) ? transform(score, transform_code) : score; i++; } } return scores; }
// [[Rcpp::export]] NumericVector CPP_row_norms_dense(NumericMatrix x, int norm_code, double p_norm = 2.0) { check_norm(norm_code, p_norm); int nr = x.nrow(), nc = x.ncol(); NumericVector norms(nr, 0.0); NumericMatrix::iterator _x = x.begin(); NumericVector::iterator _norms = norms.begin(); int i = 0; for (int col = 0; col < nc; col++) { for (int row = 0; row < nr; row++) { if (norm_code == 0) _norms[row] += _x[i] * _x[i]; else if (norm_code == 1) { if (fabs(_x[i]) > _norms[row]) _norms[row] = fabs(_x[i]); } else if (norm_code == 2) _norms[row] += fabs(_x[i]); else if (norm_code == 3) { if (p_norm > 0) _norms[row] += pow(fabs(_x[i]), p_norm); else _norms[row] += (_x[i] != 0); } i++; } } if (norm_code == 0) norms = sqrt(norms); else if (norm_code == 3 && p_norm > 1.0) norms = pow(norms, 1.0 / p_norm); /* no adjustment needed for Maximum and Manhattan norms */ return norms; }
void sapply_master(Function infun, bool realloc, bool cppfun) { // apply user-supplied function infun to each vector, update in place // realloc=true: allow function input and return dim to differ // cppfun=false: infun is regular R function // cppfun=true: infun returns XPtr to C++ function, // infun takes arma::vec&, returns void std::size_t icol, thisLen; funcPtr fun; if (cppfun) { SEXP funPtrfun = infun(); XPtr<funcPtr> xpfun(funPtrfun); fun = *xpfun; } for ( icol = 0; icol < nvec; icol++){ thisLen = lengths[icol]; NumericMatrix::iterator colStart = data.begin() + (icol * this->allocLen); // copy_aux_mem=false: reuse existing memory, modify data in-place // strict=true, arma enforces dim match, no size change allowed arma::vec dataVec(colStart, thisLen, false, !realloc); if(cppfun) { fun(dataVec); } else { FunFromR(infun, dataVec); } if ( dataVec.size() != thisLen) { // won't make it here unless realloc=true // change dimension of data matrix, reset colStart grow_assign_sapply(icol, thisLen, dataVec, colStart); } } }
// [[Rcpp::export]] Rcpp::List setlogP(NumericMatrix logP,NumericVector NegLL,NumericMatrix cbars,NumericMatrix G3) { int n = logP.nrow(), k = logP.ncol(); int l1 =cbars.ncol(); // int l2=cbars.nrow(); arma::mat logP2(logP.begin(), n, k, false); NumericVector cbartemp=cbars(0,_); NumericVector G3temp=G3(0,_); Rcpp::NumericMatrix LLconst(n,1); arma::colvec cbarrow(cbartemp.begin(),l1,false); arma::colvec G3row(G3temp.begin(),l1,false); // double v = arma::as_scalar(cbarrow.t() * cbarrow); // LLconst[j]<--t(as.matrix(cbars[j,1:l1]))%*%t(as.matrix(G3[j,1:l1]))+NegLL[j] for(int i=0;i<n;i++){ cbartemp=cbars(i,_); G3temp=G3(i,_); logP(i,1)=logP(i,0)-NegLL(i)+0.5*arma::as_scalar(cbarrow.t() * cbarrow)+arma::as_scalar(G3row.t() * cbarrow); LLconst(i,0)=NegLL(i)-arma::as_scalar(G3row.t() * cbarrow); } // return logP; return Rcpp::List::create(Rcpp::Named("logP")=logP,Rcpp::Named("LLconst")=LLconst); }
Rcpp::List setlogP_C(NumericMatrix logP,NumericVector NegLL,NumericMatrix cbars,NumericMatrix G3,NumericMatrix LLconst) { int n = logP.nrow(), k = logP.ncol(); int l1 =cbars.ncol(); arma::mat logP2(logP.begin(), n, k, false); NumericVector cbartemp=cbars(0,_); NumericVector G3temp=G3(0,_); arma::colvec cbarrow(cbartemp.begin(),l1,false); arma::colvec G3row(G3temp.begin(),l1,false); for(int i=0;i<n;i++){ cbartemp=cbars(i,_); G3temp=G3(i,_); logP(i,1)=logP(i,0)-NegLL(i)+0.5*arma::as_scalar(cbarrow.t() * cbarrow)+arma::as_scalar(G3row.t() * cbarrow); LLconst(i,0)=NegLL(i)-arma::as_scalar(G3row.t() * cbarrow); } return Rcpp::List::create(Rcpp::Named("logP")=logP,Rcpp::Named("LLconst")=LLconst); }
// [[Rcpp::export]] NumericMatrix samplehouseholds_format2(NumericMatrix phi, NumericMatrix w, NumericVector pi, NumericVector d, List lambda, int currrentbatch, int nHouseholds, int householdsize) { int K = w.nrow(); int L = w.ncol(); int p = d.length(); int n_lambdas = lambda.length(); int *lambda_columns = new int[n_lambdas]; double **lambdas = new double*[n_lambdas]; int maxDDtp = phi.nrow(); int maxdd = maxDDtp / p; //int ncol = householdsize * DIM + 1 + householdsize; //output data: zero-based //column 0: household unique index //column 1: member index within the household (pernum:person number?) //column 2 to 2+p-1: individual data //column 2+p: 2+p+n_lambdas-2: household level data //column 2+p+n_lambdas-1: household group indicator //column last hh_size: individual group indicator int DIM = 2 + p + n_lambdas - 1; //not output the household size int ncol = DIM * householdsize + householdsize + 1; NumericMatrix data(nHouseholds, ncol); //copy data from list of matrices to C++ for (int i = 0; i < n_lambdas; i++) { NumericMatrix l = lambda[i]; lambda_columns[i] = l.ncol(); lambdas[i] = new double[l.length()]; std::copy(l.begin(), l.end(), lambdas[i]); } //printf("in samplehouseholds\n"); NumericVector rand = runif(nHouseholds * ncol); //at most this many sampleHouseholds_imp_format2(data.begin(), rand.begin(), lambdas, lambda_columns, w.begin(), phi.begin(), pi.begin(),d.begin(), nHouseholds, householdsize, K, L,maxdd,p, currrentbatch,n_lambdas); //clean up delete [] lambda_columns; for (int i = 0; i < n_lambdas; i++) { delete [] lambdas[i]; } delete [] lambdas; //printf("done samplehouseholds\n"); return data; }
//--------------------------------------------------------------------- //R -> openCV Like an as. Try to minimize copying?? NOTE: Does not convert //NumericMatrix from 64bit. Do that yourself with convertTo on the Mat object //--------------------------------------------------------------------- void NumericMatrix2openCVMat(NumericMatrix dmat, Mat &odmat) { //NumericMatrix stored row-wise, but openCV Mat stored column wise?? This seems to work combind with the transpose below. Mat otmp(Size(dmat.nrow(), dmat.ncol()), CV_64F, dmat.begin(), Mat::AUTO_STEP); odmat = otmp.t(); //COULD THERE BE A PROBLEM HERE????? WHY DO WE HAVE TO DO THIS???? }
//-------------------------------------------------------------- //Test function: mMc (without PSO) //-------------------------------------------------------------- // [[Rcpp::export]] NumericMatrix kmeansreg(NumericMatrix& Rcpp_point, NumericMatrix& Rcpp_cluster_center, double p, double pw, int it_max, double inn_tol, int num_proc) { // Description of Inputs: // Rcpp_point - Clustering data for minimax clustering // Rcpp_cluster_center - Initial cluster centers // p - q in paper; approximation coefficient for minimax criterion // it_max - Maximum number of iterations for minimax clustering // num_proc - Number of processors to use in parallel computing int dim_num = Rcpp_point.ncol(); //dimension of cluster data points int point_num = Rcpp_point.nrow(); //number of cluster data points int cluster_num = Rcpp_cluster_center.nrow(); //number of desired clusters int inn_itmax = 1e4; //maximum number of agd iteration //cluster energy matrix arma::rowvec cluster_energy(cluster_num); cluster_energy.zeros(); //fill with zeros //keeps track of cluster assignment (each row for a particle) arma::rowvec cluster(point_num); cluster.ones(); //fill with -1 cluster = -1*cluster; //clustering points arma::mat point(Rcpp_point.begin(),point_num,dim_num,false); //current cluster centers (or design points) arma::mat cluster_center(Rcpp_cluster_center.begin(),cluster_num,dim_num,false); // omp_set_num_threads(num_proc); //PSO iterations Rcout << "-------------------------------------------------" << endl; Rcout << "Minimax clustering ... " << endl; Rcout << "-------------------------------------------------" << endl; kmeansreg(point,cluster_center,cluster,cluster_energy,p, pw,it_max,inn_tol,inn_itmax); //wrap to Rcpp classes for output NumericMatrix ret_cluster_center(cluster_num,dim_num); ret_cluster_center = armamatToRmat(cluster_center); return (ret_cluster_center); }
// [[Rcpp::export]] NumericVector f1_gamma(NumericMatrix b,NumericVector y,NumericMatrix x,NumericVector alpha,NumericVector wt) { // Get dimensions of x - Note: should match dimensions of // y, b, alpha, and wt (may add error checking) // May want to add method for dealing with alpha and wt when // constants instead of vectors int l1 = x.nrow(), l2 = x.ncol(); int m1 = b.ncol(); // int lalpha=alpha.nrow(); // int lwt=wt.nrow(); Rcpp::NumericMatrix b2temp(l2,1); arma::mat x2(x.begin(), l1, l2, false); arma::mat alpha2(alpha.begin(), l1, 1, false); arma::mat wt2(wt.begin(), l1, 1, false); Rcpp::NumericVector xb(l1); arma::colvec xb2(xb.begin(),l1,false); // Reuse memory - update both below // Moving Loop inside the function is key for speed NumericVector yy(l1); NumericVector res(m1); for(int i=0;i<m1;i++){ b2temp=b(Range(0,l2-1),Range(i,i)); arma::mat b2(b2temp.begin(), l2, 1, false); // mu<-t(exp(alpha+x%*%b)) // disp2<-1/wt // -sum(dgamma(y,shape=1/disp2,scale=mu*disp2,log=TRUE)) xb2=exp(alpha2+ x2 * b2); for(int j=0;j<l1;j++){ xb[j]=xb[j]/wt[j]; } yy=-dgamma_glmb(y,wt,xb,true); res(i) =std::accumulate(yy.begin(), yy.end(), 0.0); } return res; }
void LinearGaussian::init_and_weight(NumericMatrix & xparticles, NumericVector & logweights){ RNGScope scope; int nparticles = xparticles.nrow(); std::fill(xparticles.begin(), xparticles.end(), 0); xparticles(_,0) = rnorm(nparticles, 0, sigma / sqrt(1 - rho*rho)); for (int iparticle = 0; iparticle < nparticles; iparticle++){ logweights(iparticle) = Minus1Div2SdMeasurSquared * (xparticles(iparticle,0) - observations(0, 0)) * (xparticles(iparticle,0) - observations(0, 0)); } }
// [[Rcpp::export]] NumericMatrix matrixSqrt(NumericMatrix orig) { // allocate the matrix we will return NumericMatrix mat(orig.nrow(), orig.ncol()); // transform it std::transform(orig.begin(), orig.end(), mat.begin(), ::sqrt); // return the new matrix return mat; }
// remove rows with missing data from a matrix // using arma functions mat cleanmat(NumericMatrix Xr) { // get dimensions int n = Xr.nrow(),k = Xr.ncol(); mat X(Xr.begin(), n, k, false ); // create keep vector vec keep = ones<vec>(n); for (int j = 0; j < k; j++) for (int i = 0; i < n; i++) if (keep[i] && !is_finite(X(i,j))) keep[i] = 0; return X.rows(find(keep==1)); }
//' Birkhoff-Fan clustering //' //' This function computes a solution sequence of the Birkhoff-Fan clustering. //' It takes a symmetric matrix \code{S} as input and returns a object //' containing a list of normalized clustering matrices estimated by //' Birkhoff-Fan clustering over a sequence of the number of clusters. //' //' @param S input pairwise similarity matrix //' (assumed to be symmetric) //' @param nclust a vector of the number of clusters //' @param maxiter max number of iterations for each solution //' @param tolerance convergence threshold //' @param admm_penalty penalty parameter of ADMM algorithm //' @param verbose level of verbosity //' //' @return An S3 object of class \code{bfcluster} which is a list with //' the following components: //' \item{nclust}{a vector containing the number of clusters of each estimate} //' \item{clustmat}{a list containing the normalized clustering matrix //' estimates} //' \item{maxval}{a vector of optimal objective function values //' for each value of the number of clusters} //' \item{niter}{a vector containing the number of ADMM iterations for each //' estimate} //' @export // [[Rcpp::export]] List bfcluster(NumericMatrix S, IntegerVector nclust = IntegerVector::create(), int maxiter = 100, double tolerance = 1e-2, double admm_penalty = 100, int verbose = 0) { // Sanity checks if(S.nrow() < 2) stop("Expected S to be a matrix"); if(maxiter < 1) stop("Expected maxiter > 0"); if(tolerance <= 0.0) stop("Expected tolerance > 0"); int ndim = S.nrow(), nsol; if(nclust.size() > 0) { if(Rcpp::min(nclust) < 2 || Rcpp::max(nclust) > ndim) { stop("Expected nclust to be a vector of integers between 2 and the number of rows/columns of S"); } nsol = nclust.size(); } else { stop("Expected length of nclust > 0"); } // Wrap the input matrix with an arma mat const mat _S(S.begin(), ndim, ndim, false); // Placeholders for solutions List clustmat(nsol); IntegerVector niter(nsol); NumericVector maxval(nsol); // ADMM variables, passing by reference to the ADMM algorithm // Use a worm start, the results of the previous case is the initial values of the latter case // z keeps track of the solution matrix mat z = zeros<mat>(ndim, ndim), y = zeros<mat>(ndim, ndim), u = zeros<mat>(ndim, ndim), v = zeros<mat>(ndim, ndim); // Outer loop to compute the solution path for(int i = 0; i < nsol; i++) { if(verbose > 0) Rcout << "."; // ADMM niter[i] = bfadmm(_S, z, y, u, v, ndim, nclust[i], admm_penalty, maxiter, tolerance); // Store solution clustmat[i] = z; maxval[i] = dot(_S, z); if(verbose > 1) Rcout << niter[i]; } if(verbose > 0) Rcout << std::endl; // Return List out = List::create( Named("nclust") = nclust, Named("clustmat") = clustmat, Named("maxval") = maxval, Named("niter") = niter ); out.attr("class") = "bfcluster"; return out; }
// [[Rcpp::export("pcevKernel")]] SEXP pcevKernelRcpp(NumericMatrix Yr, NumericMatrix Zr, NumericVector eiValuer) { int n = Yr.nrow(), p = Yr.ncol(), q = Zr.ncol(); arma::mat Y(Yr.begin(), n, p, false); // reuses memory and avoids extra copy arma::mat Z(Zr.begin(), n, q, false); arma::colvec eiValue(eiValuer.begin(), n, false); // Initialize parameters arma::mat F(n, p, fill::zeros); arma::mat E(n, p, fill::zeros); theta param_new(fastLm(Y, Z), F, E); // Make copy and update theta param_old = param_new; param_new.update(Y, Z, eiValue); return Rcpp::List::create( Rcpp::Named("LogLik") = param_new.logLL(eiValue), Rcpp::Named("tau") = param_new.getTau(), Rcpp::Named("Sigma") = param_new.getSigma()); }
//--------------------------------------------------------------------- // //--------------------------------------------------------------------- // [[Rcpp::export]] arma::mat Reverse_Mat(NumericMatrix dmat) { arma::mat admat(dmat.begin(), dmat.nrow(), dmat.ncol(), false); //arma::mat admat = Rcpp::as<arma::mat>(dmat); arma::mat reversed_amat = fliplr(flipud(admat)); //arma::mat reversed_amat(3,3); //reversed_amat.print(); return reversed_amat; }
// [[Rcpp::export]] NumericMatrix parallelMatrixSqrt(NumericMatrix x) { // allocate the output matrix NumericMatrix output(x.nrow(), x.ncol()); // SquareRoot instance that takes a pointer to the input & output data SquareRoot squareRoot(x.begin(), output.begin()); // call parallelFor to do the work parallelFor(0, x.length(), squareRoot); // return the output matrix return output; }
// [[Rcpp::export]] NumericVector f1_binomial_cloglog(NumericMatrix b,NumericVector y,NumericMatrix x,NumericVector alpha,NumericVector wt) { // Get dimensions of x - Note: should match dimensions of // y, b, alpha, and wt (may add error checking) // May want to add method for dealing with alpha and wt when // constants instead of vectors int l1 = x.nrow(), l2 = x.ncol(); int m1 = b.ncol(); // int lalpha=alpha.nrow(); // int lwt=wt.nrow(); Rcpp::NumericMatrix b2temp(l2,1); arma::mat x2(x.begin(), l1, l2, false); arma::mat alpha2(alpha.begin(), l1, 1, false); Rcpp::NumericVector xb(l1); arma::colvec xb2(xb.begin(),l1,false); // Reuse memory - update both below // Moving Loop inside the function is key for speed NumericVector yy(l1); NumericVector res(m1); for(int i=0;i<m1;i++){ b2temp=b(Range(0,l2-1),Range(i,i)); arma::mat b2(b2temp.begin(), l2, 1, false); xb2=alpha2+ x2 * b2; xb=exp(-exp(xb)); for(int j=0;j<l1;i++){ xb(j)=1-xb(j); } yy=-dbinom_glmb(y,wt,xb,true); res(i) =std::accumulate(yy.begin(), yy.end(), 0.0); } return res; }
void update_marginal_distr(ListOf<NumericMatrix> Q, NumericMatrix res, int k, int n){ arma::mat out(res.begin(), k, n, false); for(int t=1; t<=n-1; t++){ // calculate rowsums of Q[t] arma::mat B(Q[t].begin(), k, k, false); arma::colvec rowsums = sum(B, 1); // assign rowsums to res(_, t-1) out.col(t-1) += rowsums; } // calculate colsums of Q[n-1] arma::mat B(Q[n-1].begin(), k, k, false); arma::rowvec colsums = sum(B, 0); arma::colvec temp = arma::vec(colsums.begin(), k, false, false); out.col(n-1) += temp; }
// fast linear model using RcppArmadillo functions // it does not include intercept by default, so I have to cbind(1,x) List fastLm1(NumericVector yr, NumericMatrix Xr) { int n = Xr.nrow(), k = Xr.ncol(); int df = n - k; mat X(Xr.begin(), n, k, false ); colvec y(yr.begin(), yr.size(), false ); colvec coef = solve(X, y); colvec resid = y - X*coef; double sig2 = as_scalar(trans(resid)*resid/(n-k)); colvec stderrest = sqrt( sig2 * diagvec( inv(trans(X)*X)) ); return List::create(Named("coefficients") = coef, Named("stderr") = stderrest, Named("df.residual") = df ); }
// [[Rcpp::export]] List MatrixExample(NumericMatrix orig) { NumericMatrix mat(orig.nrow(), orig.ncol()); // we could query size via // int n = mat.nrow(), k=mat.ncol(); // and loop over the elements, but using the STL is so much nicer // so we use a STL transform() algorithm on each element std::transform(orig.begin(), orig.end(), mat.begin(), sqrt_double ); List result = List::create( Named( "result" ) = mat, Named( "original" ) = orig ); return result ; }