// [[Rcpp::export]]
Rcpp::List calib( arma::mat Y,
arma::vec C,
arma::mat Z,
NumericVector mu_input,
IntegerVector mu_dim,
NumericVector mu0_input,
IntegerVector mu0_dim
)
{
arma::cube mu(mu_input.begin(), mu_dim[0], mu_dim[1], mu_dim[2]);
arma::cube mu0(mu0_input.begin(), mu0_dim[0], mu0_dim[1], mu0_dim[2]);
int n = Y.n_rows;
int p = Y.n_cols;
int niter = Z.n_rows;
cube calibration(niter,p,n); calibration.fill(0);
mat calibrationMedian(n,p); calibrationMedian.fill(0);
for(int it=0; it<niter; it++)
{
for(int i=0; i<n; i++)
calibration.slice(i).row(it) = mu.slice(it).cols(Z(it,i)*p,Z(it,i)*p+p-1).row(C(i)) - mu0.slice(it).col(Z(it,i)).t();
}
for( int i = 0; i < n; i++)
calibrationMedian.row(i) = median(calibration.slice(i),0);
return Rcpp::List::create(
Rcpp::Named( "Y_cal" ) = Y - calibrationMedian,
Rcpp::Named( "calibration_distribution" ) = calibration,
Rcpp::Named( "calibration_median" ) = calibrationMedian
) ;
}
// [[Rcpp::export]]
SEXP compPvals2(NumericVector nullvec, NumericVector vec) { //Try above except with iterators. Runs about as fast.
int n = nullvec.size();
int m = vec.size();
Rcpp::NumericVector pvalVec(m);
typedef Rcpp::NumericVector::iterator vec_iterator;
vec_iterator it_nv = nullvec.begin();
vec_iterator it_v = vec.begin();
vec_iterator it_pv = pvalVec.begin();
for(int i=0; i<m; i++) {
int count = 0;
for(int j=0; j<n; j++) {
count = count + (it_nv[j]>=it_v[i]);
//cout<<count<<endl;
}
double val = ((double)count)/((double)n);
//cout<<val<<endl;
it_pv[i] = val;
}
return pvalVec;
}
// [[Rcpp::export]]
S4 CPP_scale_margins_sparse(S4 M, NumericVector rows, NumericVector cols, bool duplicate = true) {
if (!M.is("dgCMatrix"))
stop("internal error -- not a canonical sparse matrix");
IntegerVector dims = M.slot("Dim");
int nr = dims[0], nc = dims[1];
if (nr != rows.size() || nc != cols.size())
stop("internal error -- row/column weights not conformable with matrix");
if (duplicate)
M = clone(M);
IntegerVector p = M.slot("p");
IntegerVector::iterator _p = p.begin();
IntegerVector row_of = M.slot("i");
IntegerVector::iterator _row_of = row_of.begin();
NumericVector x = M.slot("x");
NumericVector::iterator _x = x.begin();
NumericVector::iterator _rows = rows.begin();
for (int col = 0; col < nc; col++) {
double col_weight = cols[col];
for (int i = _p[col]; i < _p[col+1]; i++) {
_x[i] *= _rows[_row_of[i]] * col_weight;
}
}
return M;
}
// [[Rcpp::export]]
NumericVector CPP_dsm_score_sparse(int nr, int nc, IntegerVector p, IntegerVector row_of, NumericVector 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 */
// -- don't check whether sparse=TRUE, so power users can compute non-sparse AMs for nonzero entries of the sparse matrix
// if (!sparse) stop("only sparse association scores can be used with sparse matrix representation");
int n_items = f.size();
NumericVector scores(n_items);
if (am_code != 0 && (nr != f1.size() || nc != f2.size()))
stop("internal error -- marginal vectors f1 and f2 not conformable with matrix f");
IntegerVector::iterator _p = p.begin();
IntegerVector::iterator _row_of = row_of.begin();
NumericVector::iterator _f = f.begin();
NumericVector::iterator _f1 = f1.begin();
NumericVector::iterator _f2 = f2.begin();
NumericVector::iterator _scores = scores.begin();
for (int col = 0; col < nc; col++) {
for (int i = _p[col]; i < _p[col+1]; i++) {
/* frequeny measure (*am_code == 0) is a special case, since marginals may not be available ("reweight" mode) */
double score = (am_code == 0) ? _f[i] : AM(_f[i], _f1[_row_of[i]], _f2[col], N, sparse);
_scores[i] = (transform_code) ? transform(score, transform_code) : score;
}
}
return scores;
}
// [[Rcpp::export]]
NumericVector ptsThresh(NumericVector values,NumericVector endDates,int window){
int valuesLen = values.length();
NumericVector out = clone(values);
NumericVector startDates = endDates - window;
for (int i = 0; i < valuesLen; ++i){
LogicalVector idx = (endDates <= endDates[i]) & (endDates >= startDates[i]);
NumericVector valuesWindow = values[idx];
int lenCur = valuesWindow.length();
if (lenCur == 1){
out[i] = (1.4 / 1.3) * valuesWindow[i];
}
if (lenCur == 2){
out[i] = (1.5 / 2.4) * sum(valuesWindow);
}
if (lenCur == 3){
out[i] = (1.5 / 3.3) * sum(valuesWindow);
}
if (lenCur == 4){
out[i] = (1.5 / 4.0) * sum(valuesWindow);
}
if (lenCur >= 5){
std::nth_element(valuesWindow.begin(),valuesWindow.begin() + 5,valuesWindow.end());
out[i] = valuesWindow[4];
}
}
return out;
}
// [[Rcpp::export]]
SEXP compPvals3(NumericVector nullvec, NumericVector vec) { //A fancyer version using iterators. Actually runs much slower!!!!
int n = nullvec.size();
int m = vec.size();
Rcpp::NumericVector pvalVec(m);
typedef Rcpp::NumericVector::iterator vec_iterator;
//vec_iterator it_nv = nullvec.begin();
//vec_iterator it_v = vec.begin();
//vec_iterator it_pv = pvalVec.begin();
for(vec_iterator it_v = vec.begin(), it_pv = pvalVec.begin(); it_v != vec.end(); ++it_v, ++it_pv) {
int count = 0;
for(vec_iterator it_nv = nullvec.begin(); it_nv != nullvec.end(); ++it_nv) {
count = count + ( *it_nv >= *it_v );
//cout<<count<<endl;
}
double val = ((double)count)/((double)n);
//cout<<val<<endl;
*it_pv = val;
}
return pvalVec;
}
// [[Rcpp::export]]
NumericVector ddirichlet(NumericVector xx , NumericVector alphaa){
if (is_true(any(alphaa<=0))){
return wrap(-1e20);
}
if (is_true(any( (xx <=0) ))){
return wrap(-1e20);
}
double alpha_sum = std::accumulate(alphaa.begin(), alphaa.end(), 0.0);
// this will return alpha_sum = 0 0 0
//return (alpha_sum);
NumericVector log_gamma_alpha = lgamma(alphaa);
NumericVector log_alpha_sum = lgamma(wrap(alpha_sum));
double sum_log_gamma_alpha = std::accumulate(log_gamma_alpha.begin(), log_gamma_alpha.end(), 0.0);
double logD = sum_log_gamma_alpha - as<double>(log_alpha_sum);
NumericVector a = ( alphaa - 1.0 ) * log(xx);
return wrap( std::accumulate(a.begin(), a.end(), 0.0) - logD );
}
// [[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;
}
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;
}
// [[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;
}
// [[Rcpp::export]]
NumericVector row_kth(NumericMatrix toSort, int k) {
int n = toSort.rows();
NumericVector meds = NumericVector(n);
for (int i = 0; i < n; i++) {
NumericVector curRow = toSort.row(i);
std::nth_element(curRow.begin(), curRow.begin() + k, curRow.end());
meds[i] = curRow[k];
}
return meds;
}
//' Empirical sample quantile.
//' Calculate empirical sample quantile.
//'
//' @param x A numeric vector, specifying the sample for which the quantile is to be calculated.
//' @param q A real number between 0 and 1 inclusive, specifying the desired quantile.
//'
//' @return The empirical quantile of the provided sample.
//' @examples
//' x<-rnorm(100)
//' qsamp(x, 0.5)
//' @export
// [[Rcpp::export]]
double qsamp(NumericVector x, double q)
{
int n = x.size();
int Q = floor(n*q);
double g = n*q-double(Q);
if (g == 0) Q -= 1; //Q = Q, but c++ uses 0-based indexing
else Q = Q; //Q -= 1 0-based indexing
std::nth_element(x.begin(), x.begin()+Q, x.end());
return x[Q];
}
// Quick and dirty implementation of lowerBound, the complement to R's
// findInterval
// [[Rcpp::export]]
IntegerVector lowerBound(const NumericVector& x, const NumericVector& breaks) {
int n = x.size();
IntegerVector out(n);
for (int i = 0; i < n; i++) {
NumericVector::const_iterator it =
std::lower_bound(breaks.begin(), breaks.end(), x[i]);
if (it == breaks.end()) --it;
out[i] = it - breaks.begin() + 1;
}
return out;
}
// [[Rcpp::export]]
SEXP C_MedianSpec(SEXP x) {
NumericMatrix VV(x);
int n_specs = VV.nrow();
int count_max = VV.ncol();
int position = n_specs / 2; // Euclidian division
NumericVector out(count_max);
for (int j = 0; j < count_max; j++) {
NumericVector y = VV(_,j); // Copy column -- original will not be mod
std::nth_element(y.begin(), y.begin() + position, y.end());
out[j] = y[position];
}
return out;
}
//' Compute complex visibility based on ABCD principle
//'
//' @param ii ABCD
//' @param kx P2VM. By default, c(0,2,2,0)
//' @param sx P2VM. By default, c(4,4,4,4)
//' @param fx Total flux in ABCD
//'
// [[Rcpp::export]]
ComplexVector gv_abcd2vis(NumericVector ii,
NumericVector kx = NumericVector::create(4),
NumericVector sx = NumericVector::create(4),
NumericVector fx = NumericVector::create(1))
{
double vv[2] = {0,0};
ComplexVector vis = ComplexVector(1);
abcd2vis(ii.begin(), kx.begin(), sx.begin(), &vv[0], as<double>(fx));
vis[0].r = vv[0];
vis[0].i = vv[1];
return vis;
}
//' FITS image writer
//'
//' Writes a vector, matrix or 3D array to a FITS file as an image.
//' The data is written to the primary HDU.
//'
// [[Rcpp::export]]
int gv_writefits_img(NumericVector img, CharacterVector fits_name, CharacterVector hdu_name = "")
{
IntegerVector dim;
if (!img.hasAttribute("dim"))
{
REprintf("ERROR: image has not been dimensioned.\n");
return 1;
}
dim = img.attr("dim");
if (dim.length() > 3)
{
REprintf("ERROR: dimension of more than 3 unsupported.\n");
return 1;
}
fitsfile *pfits=NULL;
int err=0;
std::string fname = as<std::string>(fits_name[0]);
fits_create_file(&pfits, (char *) fname.c_str(), &err);
if (err)
{
gv_print_fits_err(err);
return err;
}
#ifdef GV_DEBUG
Rcout << "Number of dim: " << dim.length() << std::endl;
for (int i=0; i<dim.length(); i++)
{
Rcout << "Dim[" << i << "]: " << dim[i] << std::endl;
}
Rcout << "Number of elements: " << img.length() << std::endl;
double *p = &(*img.begin());
for (int i=0; i<img.length(); i++)
{
Rcout << "*(p+" << i << ") = " << *(p+i) << std::endl;
}
#endif
long longdim[3], startpix[3] = {1,1,1}; // default start
for (int i=0; i<dim.length(); i++) longdim[i] = (long) dim[i];
// start writing to file
fits_create_img(pfits, DOUBLE_IMG, dim.length(), longdim, &err);
fits_write_pix(pfits, TDOUBLE, startpix, img.length(), &(*img.begin()), &err);
fits_close_file(pfits, &err);
return err;
}
struct spl spl_init(NumericVector x, NumericVector y){
gsl_set_error_handler_off();
struct spl out;
int nx = x.size();
out.x = x;
out.y = y;
out.acc= gsl_interp_accel_alloc();
out.spline = gsl_spline_alloc( gsl_interp_cspline , nx );
double eps = 0.0001;
gsl_spline_init(out.spline, x.begin(), y.begin(), nx);
out.slope_first= (gsl_spline_eval (out.spline, x[0]+eps, out.acc) - y[0])/eps;
out.slope_end = (y[nx-1] - gsl_spline_eval (out.spline, x[nx-1]-eps, out.acc))/eps;
return(out);
}
// [[Rcpp::export]]
double pmvnorm(NumericVector lls, NumericVector uls,
NumericVector mu, NumericMatrix sigma) {
int n = 2, nu = 0, maxpts = 2000, inform;
int infin [2] = {2, 2};
double abseps = 1/1000, releps = 1/1000, error, value;
int rnd = 1;
double corr = sigma(0, 1) / sqrt(sigma(0, 0) * sigma(1, 1));
/* mvtnorm_C_mvtdst is defined in mvtnorm/inst/include/mvtnormAPI.h */
mvtnorm_C_mvtdst(&n, &nu, lls.begin(), uls.begin(), infin, &corr, mu.begin(),
&maxpts, &abseps, &releps, &error, &value, &inform, &rnd);
return value;
}
// [[Rcpp::export]]
void appendRcpp( List fillVecs, NumericVector newLengths, NumericMatrix retmat, NumericVector retmatLengths ) {
/* appendRcpp
Fills numeric matrix
Loop through rows, filling retmat in with the vectors in list
then update return matrix size to index the next free
*/
// Declare vars
NumericVector fillTmp;
int sizeOld, sizeNew;
// Pull out dimensions of return matrix to fill
int nrow = retmat.nrow();
int ncol = retmat.ncol();
// Check that dimensions match
if ( nrow != retmatLengths.size() || nrow != fillVecs.size() ) {
throw std::range_error("In appendC(): dimension mismatch");
}
// Traverse ddimensions
for (int ii=0; ii<ncol; ii++) {
throw std::range_error("In appendC(): exceeded max cols");
// Iterator for row to fill
NumericMatrix::Row retRow = retmat(ii, _);
// Fill row of return matrix, starting at first non-zero element
std::copy( fillTmp.begin(), fillTmp.end(), retRow.begin() + sizeOld );
// Update size of return matrix
retmatLengths[ii] = sizeNew;
}
}
double glmResp::updateWts() {
d_sqrtrwt = sqrt(d_weights/d_fam.variance(d_mu));
NumericVector muEta = d_fam.muEta(d_eta);
std::transform(muEta.begin(), muEta.end(), d_sqrtrwt.begin(),
d_sqrtXwt.begin(), std::multiplies<double>());
return updateWrss();
}
// [[Rcpp::export]]
SEXP multFct_left(SEXP x, NumericVector f, SEXP g) {
// Multiply a matFct by a matrix from the left
// No sanity check performed!
NumericVector vec_x(x);
NumericVector vec_g(g);
IntegerVector dims1 = vec_x.attr("dim");
IntegerVector dims2 = vec_g.attr("dim");
int p = dims2[2]; // NB: 1 less in order to simplify code
int r = dims2[3];
int rp = r*p;
arma::mat xx(vec_x.begin(), dims1[0], dims1[1], false);
arma::cube yf(f.begin(), dims2[0], dims2[1], p+1, false);
arma::cube yg(vec_g.begin(), dims2[0], dims2[1], rp, false);
arma::cube ff(dims1[0], dims2[1], p+1);
arma::cube gg(dims1[0], dims2[1], rp);
// find f and g functions
for (int j=0; j<=p; j++) ff.slice(j) = xx*yf.slice(j);
for (int j=0; j<rp; j++) gg.slice(j) = xx*yg.slice(j);
// return to R
return(List::create(Rcpp::Named("f")=ff, Rcpp::Named("g")=gg));
}
// [[Rcpp::export]]
List split_runs_numeric( NumericVector X ) {
List out( X.size() );
std::vector< std::vector< double > > all_nums;
std::vector< double > curr_nums;
// initial stuff
curr_nums.push_back( X[0] );
for( NumericVector::iterator it = X.begin()+1; it != X.end(); ++it ) {
if( (*it) != (*(it-1)) ) {
all_nums.push_back( curr_nums );
curr_nums.clear();
curr_nums.push_back( *it );
} else {
curr_nums.push_back( *it );
}
}
// push the final vector in
all_nums.push_back( curr_nums );
return wrap( all_nums );
}
Rcpp::NumericVector glmerResp::sqrtWrkWt() const {
NumericVector me = muEta();
#ifdef USE_RCPP_SUGAR
return sqrt(d_weights * me * me / variance());
#else
NumericVector vv = variance();
std::transform(me.begin(), me.end(), me.begin(), me.begin(),
std::multiplies<double>());
std::transform(me.begin(), me.end(), d_weights.begin(),
me.begin(), std::multiplies<double>());
std::transform(me.begin(), me.end(), vv.begin(), me.begin(),
std::divides<double>());
std::transform(me.begin(), me.end(), me.begin(), &::sqrt);
return me;
#endif
}
// [[Rcpp::export]]
NumericVector CPP_row_norms_sparse(int nr, int nc, IntegerVector p, IntegerVector row_of, NumericVector x, int norm_code, double p_norm = 2.0) {
check_norm(norm_code, p_norm);
NumericVector norms(nr, 0.0);
NumericVector::iterator _x = x.begin();
IntegerVector::iterator _p = p.begin();
IntegerVector::iterator _row_of = row_of.begin();
NumericVector::iterator _norms = norms.begin();
for (int col = 0; col < nc; col++) {
for (int i = _p[col]; i < _p[col+1]; i++) {
int row = _row_of[i];
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);
}
}
}
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 append( List fillVecs) {
// "append" fill oldmat w/
// we will loop through cols, filling retmat in with the vectors in list
// then update retmat_size to index the next free
// newLenths isn't used, added for compatibility
std::size_t sizeOld, sizeAdd, sizeNew, icol;
NumericVector fillTmp;
// check that number of vectors match
if ( nvec != fillVecs.size()) {
throw std::range_error("In append(): dimension mismatch");
}
for (icol = 0; icol<nvec; icol++){
// vector to append
fillTmp = fillVecs[icol];
// compute lengths
sizeOld = lengths[icol];
sizeAdd = fillTmp.size();
sizeNew = sizeOld + sizeAdd;
// grow data matrix as needed
if ( sizeNew > allocLen) {
grow(sizeNew);
}
// iterator for col to fill
NumericMatrix::Column dataCol = data(_, icol);
// fill row of return matrix, starting at first non-zero elem
std::copy( fillTmp.begin(), fillTmp.end(), dataCol.begin() + sizeOld);
// update size of retmat
lengths[icol] = sizeNew;
}
}
// [[Rcpp::export]]
NumericVector CPP_col_norms_sparse(int nr, int nc, IntegerVector p, IntegerVector row_of, NumericVector x, int norm_code, double p_norm = 2.0) {
check_norm(norm_code, p_norm);
NumericVector norms(nc, 0.0);
NumericVector::iterator _x = x.begin();
IntegerVector::iterator _p = p.begin();
// IntegerVector::iterator _row_of = row_of.begin();
NumericVector::iterator _norms = norms.begin();
for (int col = 0; col < nc; col++) {
double accum = 0.0;
for (int i = _p[col]; i < _p[col+1]; i++) {
if (norm_code == 0) accum += _x[i] * _x[i];
else if (norm_code == 1) { if (fabs(_x[i]) > accum) accum = fabs(_x[i]); }
else if (norm_code == 2) accum += fabs(_x[i]);
else if (norm_code == 3) {
if (p_norm > 0)
accum += pow(fabs(_x[i]), p_norm);
else
accum += (_x[i] != 0);
}
}
if (norm_code == 0) _norms[col] = sqrt(accum);
else if (norm_code == 3 && p_norm > 1.0) _norms[col] = pow(accum, 1.0 / p_norm);
else /* other norms */ _norms[col] = accum;
}
return norms;
}
// [[Rcpp::export]]
List instrumented_count_positive_threaded(NumericVector data, int nthreads){
int n = data.size() ;
int chunk_size = n / nthreads ;
std::vector<Timer> timers(nthreads) ;
std::vector<std::future<int>> futures(nthreads-1) ;
std::vector<std::thread> threads(nthreads-1) ;
timers[0].step("data structures") ;
double* it = data.begin() ;
for( int i=0; i<nthreads-1; i++){
InstrumentedTask instr_task(timers[i+1]) ;
Task task(instr_task) ;
futures[i] = task.get_future();
threads[i] = std::thread( std::move(task), it, it + chunk_size ) ;
it += chunk_size ;
timers[0].step( "spawning" ) ;
}
timers[0].step( "spawning" ) ;
int result = InstrumentedTask(timers[0])(it, data.end());
for( int i=0; i<nthreads-1; i++) {
threads[i].join() ;
timers[0].step("fusion") ;
result += futures[i].get() ;
}
timers[0].step( "fusion" ) ;
return List::create( _["res"] = result, _["timers"] = timers );
}
// [[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]]
arma::cube gibbsCPP(NumericVector p2, int T, int M, double rho, double x0, double y0)
{
IntegerVector dim_p2=p2.attr("dim");
arma::cube p(p2.begin(), dim_p2[0], dim_p2[1], dim_p2[2]);
double x, y;
arma::vec n1 = rnormC(76543,M*T);
//arma::vec n2 = rnormC(76543,M*T);
for(int m=0;m<M;m++)
{
x = x0;
y = y0;
p(0,0,m) = x;
p(1,0,m) = y;
for(int t=1;t<T;t++)
{
//x = rnormC(1,M*T)[m*t];
//x = x * sqrt(1-pow(rho,2)) + rho * y;
//y = rnormC(76543,M*T)[(m*t)+1];
//y = y * sqrt(1-pow(rho,2)) + rho * x;
x = n1[m*T];
x = x * sqrt(1-pow(rho,2)) + rho * y;
y = n1[m*T+1];
y = y * sqrt(1-pow(rho,2)) + rho * x;
p(0,t,m) = x;
p(1,t,m) = y;
}
}
return(p);
}
//' Sorted vector index.
//'
//' The sorted vector is returned along with the original index of the vector it belonged to.
//'
//' @param x A real-valued vector to be sorted.
//'
//' @return A list with two components:
//' \itemize{
//' \item sorted: The sorted version of \code{x}.
//' \item index: The index of the \eqn{i^{th}} element in \code{x}.
//' }
//'
//' @examples
//' pairSort(c(5, 2, 6))
//' @export
//[[Rcpp::export]]
List pairSort(NumericVector x)
{
int n = x.size();
NumericVector x_sorted(n);
IntegerVector x_index(n);
std::vector<double> arr(x.begin(), x.end());
std::vector<std::pair<double,int> >V;
for (int i=0; i<x.size(); i++)
{
std::pair<double,int>P = std::make_pair(arr[i], i);
V.push_back(P);
}
std::sort(V.begin(), V.end());
for (int i=0; i<x.size(); i++)
{
x_sorted[i] = V[i].first;
x_index[i] = V[i].second;
}
return List::create(_["sorted"] = x_sorted,
_["index"] = x_index);
}
