// [[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 ;
}
