// [[Rcpp::export]]
NumericMatrix rectify(NumericMatrix m){
NumericMatrix out(m.nrow(), m.ncol());
for(int i = 0; i< m.ncol(); i++){
out(_, i) = clamp(0, m(_, i), INFINITY);
};
return out;
}
// [[Rcpp::export]]
NumericMatrix sortMatrix(NumericMatrix bipartiteAdjMatrix) {
int numRows = bipartiteAdjMatrix.nrow();
int numCols = bipartiteAdjMatrix.ncol();
std::vector<myPair> colSums(numCols);
std::vector<myPair> rowSums(numRows);
NumericMatrix sortedMatrix(bipartiteAdjMatrix.nrow(), bipartiteAdjMatrix.ncol());
//calculate row and column sums
for(int rowIdx = 0; rowIdx < numRows; rowIdx++) {
rowSums[rowIdx].second = rowIdx;
for(int colIdx = 0; colIdx < numCols; colIdx++) {
colSums[colIdx].second = colIdx;
rowSums[rowIdx].first += bipartiteAdjMatrix(rowIdx,colIdx);
colSums[colIdx].first += bipartiteAdjMatrix(rowIdx,colIdx);
}
}
//sort with custom comparator method
std::sort(rowSums.begin(), rowSums.end(), comparator_r);
std::sort(colSums.begin(), colSums.end(), comparator_r);
//create sorted matrix by cross-referencing sorted indexes
for(int rowIdx = 0; rowIdx < numRows; rowIdx++) {
for(int colIdx = 0; colIdx < numCols; colIdx++) {
sortedMatrix(rowIdx, colIdx) = bipartiteAdjMatrix(rowSums[rowIdx].second, colSums[colIdx].second);
}
}
return sortedMatrix;
}
// [[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::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::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("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);
}
// [[Rcpp::export]]
NumericVector smooth_nd(const NumericMatrix& grid_in,
const NumericVector& z_in,
const NumericVector& w_in_,
const NumericMatrix& grid_out,
const NumericVector h) {
if (grid_in.nrow() != z_in.size()) stop("Incompatible input lengths");
if (grid_in.ncol() != grid_out.ncol()) stop("Incompatible grid sizes");
if (h.size() != grid_in.ncol()) stop("Incorrect h length");
int n_in = grid_in.nrow(), n_out = grid_out.nrow(), d = grid_in.ncol();
NumericVector w_in = (w_in_.size() > 0) ? w_in_ :
rep(NumericVector::create(1), n_in);
NumericVector z_out(n_out), w_out(n_out);
for (int i = 0; i < n_in; ++i) {
for(int j = 0; j < n_out; ++j) {
double w = 1;
for (int k = 0; k < d; ++k) {
double dist = (grid_in(i, k) - grid_out(j, k)) / h[k];
w *= tricube(dist);
}
w *= w_in[i];
w_out[j] += w;
z_out[j] += z_in[i] * w;
}
}
for(int j = 0; j < n_out; ++j) {
z_out[j] /= w_out[j];
}
return z_out;
}
// [[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;
}
// Function to calculate deviation from parity from cd matrix
NumericVector distParity(NumericMatrix mat,
NumericVector popvec)
{
/* Inputs to function:
mat: Matrix of congressional district assignments
popvec: vector of geographic unit populations
*/
// Get the unique cd labels
NumericVector labs = unique(mat(_,0));
// Calculate parity
double parity = (double)sum(popvec) / labs.size();
// Container vector of plan deviations
NumericVector plandevs(mat.ncol());
// Loop through plans
for(int i = 0; i < mat.ncol(); i++){
// Get plan
arma::vec plan = mat(_,i);
// Loop through assignments
double maxdev = 0.0;
for(int j = 0; j < labs.size(); j++){
arma::uvec assignments = find(plan == labs(j));
// Loop over precincts in plan
int distpop = 0;
for(int k = 0; k < assignments.size(); k++){
distpop += popvec(assignments(k));
}
// Get deviation from parity
double plandev = std::abs((double)((double)distpop - parity) / parity);
if(plandev > maxdev){
maxdev = plandev;
}
}
// Store maxdev in plandevs
plandevs(i) = maxdev;
}
return plandevs;
}
// [[Rcpp::export]]
NumericVector getLengths(NumericMatrix xs, NumericMatrix ys) {
NumericVector x(xs.ncol()), y(ys.ncol());
NumericVector Lengths(xs.nrow());
for(int i = 0; i < xs.nrow(); i++){
x = xs(i,_);
y = ys(i,_);
Lengths[i] = getLength(x,y);
}
return Lengths;
}
// [[Rcpp::export]]
double sample_gamma_scalar(NumericVector y, List x, NumericMatrix groups,
NumericMatrix beta, List gamma, NumericVector delta,
NumericMatrix z, double alpha, double sigma2,
List bs_beta, NumericVector sigma2_gamma,
int q_id, int G_id) {
double out;
NumericVector params(2);
double sum_term = 0.0;
double sum_term2 = 0.0;
double sum_term2a = 0.0;
double sum_term2b = 0.0;
double sum_term3 = 0.0;
double sum_term4 = 0.0;
for (int i = 0; i < y.size(); i++) {
if (groups(i, q_id) == G_id) {
double term = 0.0;
for (int k = 0; k < beta.nrow(); k++) {
NumericMatrix bs_beta_k = bs_beta[k];
NumericMatrix x_k = x[k];
for (int j = 0; j < x_k.ncol(); j++) {
for (int p = 0; p < beta.ncol(); p++) {
term += beta(k, p) * bs_beta_k(j, p) * x_k(i, j);
}
}
}
sum_term += 1;
sum_term2 += y[i];
sum_term2a += alpha;
sum_term2b += term;
for (int k = 0; k < z.ncol(); k++) {
sum_term4 += delta[k] * z(i, k);
}
for (int q = 0; q < gamma.size(); q++) {
if (q != q_id) {
NumericVector gamma_q = gamma[q];
int group_set = groups(i, q);
sum_term3 += gamma_q[group_set];
}
}
}
}
//Calculate params[1]
params[1] = (sigma2 * sigma2_gamma[q_id]) / (sigma2_gamma[q_id] * sum_term + sigma2);
//Calculate params[0]
params[0] = params[1] * (-1.0 / (2.0 * sigma2)) * (-2.0 * sum_term2 + 2.0 * sum_term2a +
2.0 * sum_term2b + 2.0 * sum_term3 +
2.0 * sum_term4);
//Calculate loglik
out = rnorm(1, params[0], sqrt(params[1]))[0];
return out;
}
//' 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;
}
// [[Rcpp::export]]
NumericMatrix cpp_rdirichlet(
const int& n,
const NumericMatrix& alpha
) {
if (std::min({alpha.nrow(), alpha.ncol()}) < 1) {
Rcpp::warning("NAs produced");
NumericMatrix out(n, alpha.ncol());
std::fill(out.begin(), out.end(), NA_REAL);
return out;
}
int k = alpha.ncol();
NumericMatrix x(n, k);
bool throw_warning = false;
if (k < 2)
Rcpp::stop("number of columns in alpha should be >= 2");
double row_sum, sum_alpha;
bool wrong_values;
for (int i = 0; i < n; i++) {
sum_alpha = 0.0;
row_sum = 0.0;
wrong_values = false;
for (int j = 0; j < k; j++) {
sum_alpha += GETM(alpha, i, j);
if (GETM(alpha, i, j) <= 0.0) {
wrong_values = true;
break;
}
x(i, j) = R::rgamma(GETM(alpha, i, j), 1.0);
row_sum += x(i, j);
}
if (ISNAN(sum_alpha) || wrong_values) {
throw_warning = true;
for (int j = 0; j < k; j++)
x(i, j) = NA_REAL;
} else {
for (int j = 0; j < k; j++)
x(i, j) /= row_sum;
}
}
if (throw_warning)
Rcpp::warning("NAs produced");
return x;
}
//' 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]]
NumericVector smooth_nd_1(const NumericMatrix& grid_in,
const NumericVector& z_in,
const NumericVector& w_in_,
const NumericMatrix& grid_out,
const int var, const double h,
const std::string type = "mean") {
if (var < 0) stop("var < 0");
if (var >= grid_in.ncol()) stop("var too large");
if (h <= 0) stop("h <= 0");
if (grid_in.ncol() != grid_out.ncol()) stop("Incompatible grid sizes");
int n_in = grid_in.nrow(), n_out = grid_out.nrow(), d = grid_in.ncol();
NumericVector w_in = (w_in_.size() > 0) ? w_in_ :
rep(NumericVector::create(1), n_in);
NumericVector z_out(n_out), w_out(n_out);
// Will be much more efficient to slice up by input dimension:
// and most efficient way of doing that will be to bin with / bw
// My data structure: sparse grids
//
// And once we're smoothing in one direction, with guaranteed e2venly spaced
// grid can avoid many kernel evaluations and can also compute more
// efficient running sum
for(int j = 0; j < n_out; ++j) {
boost::shared_ptr<Summary2d> summary = createSummary(type);
for (int i = 0; i < n_in; ++i) {
// Check that all variables (apart from var) are equal
bool equiv = true;
for (int k = 0; k < d; ++k) {
if (k == var) continue;
double in = grid_in(i, k), out = grid_out(j, k);
if (in != out && !both_na(in, out)) {
equiv = false;
break;
}
};
if (!equiv) continue;
double in = grid_in(i, var), out = grid_out(j, var);
double dist = both_na(in, out) ? 0 : in - out;
double w = tricube(dist / h) * w_in[i];
if (w == 0) continue;
summary->push(dist, z_in[i], w);
}
z_out[j] = summary->compute();
}
return z_out;
}
//---------------------------------------------------------------------
//
//---------------------------------------------------------------------
// [[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 parallelMatrixSqrt(NumericMatrix x) {
// allocate the output matrix
NumericMatrix output(x.nrow(), x.ncol());
// SquareRoot functor (pass input and output matrixes)
SquareRoot squareRoot(x, output);
// call parallelFor to do the work
parallelFor(0, x.nrow() * x.ncol(), squareRoot);
// return the output matrix
return output;
}
// [[Rcpp::export]]
List bsplitC(NumericMatrix Dmat, NumericMatrix Xmat, NumericVector parm) {
int J = Dmat.ncol() - 1, nsub = Dmat.nrow(), nbeta = Xmat.ncol(), id = -1, j;
NumericVector result(2, -9999999999), temp(2), xtemp(nsub);
for (int i=0; i < nbeta; i++) {
xtemp = Xmat(_, i);
temp = splitpt(Dmat, xtemp, parm);
if (temp[1] >= result[1]) {
id = i;
result[0] = temp[0];
result[1] = temp[1];
}
}
return List::create(id + 1, result);
}
// Sends employed Bees
void SendEmployedBees(
double & GlobalMin,
NumericVector & GlobalParams,
NumericVector & fitness,
NumericVector & f,
IntegerVector & trial,
Function & fun,
NumericMatrix & Foods,
const NumericVector & lb,
const NumericVector & ub
) {
int param2change, neighbour;
double ObjValSol, FitnessSol;
NumericVector solution(Foods.ncol());
for (int i=0;i<Foods.nrow();i++) {
// Random parameter to change
param2change = (int)(unif_rand()*Foods.ncol());
// Random neighbour to select
neighbour = i;
while (neighbour == i)
neighbour = (int)(unif_rand()*Foods.nrow());
// Suggesting new solution
solution = Foods(i,_);
solution[param2change] = Foods(i,param2change) +
(Foods(i, param2change) - Foods(neighbour, param2change))*(unif_rand()-.5)*2;
// Truncating
if (solution[param2change] < lb.at(param2change))
solution[param2change] = lb.at(param2change);
if (solution[param2change] > ub.at(param2change))
solution[param2change] = ub.at(param2change);
// Comparing current solution with new one
ObjValSol = as<double>(fun(solution));
FitnessSol = CalculateFitness(ObjValSol);
if (FitnessSol > fitness[i]) {
Foods(i,_) = solution;
fitness[i] = FitnessSol;
f[i] = ObjValSol;
trial[i] = 0;
} else {
trial[i]+=1;
}
}
return;
}
// [[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;
}
NumericMatrix cbindCpp(NumericMatrix a, NumericMatrix b) {
int acoln = a.ncol();
int bcoln = b.ncol();
NumericMatrix out(a.nrow(), acoln + bcoln);
for (int j = 0; j < acoln + bcoln; j++) {
if (j < acoln) {
out(_, j) = a(_,j);
} else {
out(_, j) = b(_,j-acoln);
}
}
return out;
}
// [[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;
}
// @export
// [[Rcpp::export]]
NumericMatrix cpp_omitMatrix(const NumericMatrix& ExpressionSet, const NumericVector& AgeVector){
int nRows = ExpressionSet.nrow();
int nCols = ExpressionSet.ncol();
NumericMatrix ResultMatrix(nRows,nCols);
NumericVector NumeratorVector(nCols);
NumericVector DivisorVector(nCols);
for(int stage = 0; stage < nCols; stage++) {
double numerator = 0, divisor = 0;
for(int gene = 0; gene < nRows; gene++) {
numerator+= (double) AgeVector[gene] * ExpressionSet(gene, stage);
divisor += ExpressionSet(gene, stage);
}
NumeratorVector[stage] = numerator;
DivisorVector[stage] = divisor;
}
for(int stage = 0; stage < nCols; stage++){
double newNumerator = 0, newDivisor = 0;
for(int gene = 0; gene < nRows; gene++){
newNumerator = (double) NumeratorVector[stage] - (AgeVector[gene] * ExpressionSet(gene, stage));
newDivisor = (double) DivisorVector[stage] - ExpressionSet(gene, stage);
ResultMatrix(gene,stage) = newNumerator / newDivisor;
}
}
return ResultMatrix;
}
// [[Rcpp::export]]
NumericVector calc_rr_cds(NumericVector outcome, NumericMatrix covars) {
int nrow = covars.nrow(), ncol = covars.ncol();
if (outcome.length() != nrow) {
stop("length of outcome should be the same as the number of rows in covars");
}
NumericVector out(ncol);
out.attr("names") = colnames(covars);
for (int j = 0; j < ncol; j++) {
double outcomes1 = 0;
double outcomes0 = 0;
double n1 = 0;
double n0 = 0;
for (int i = 0; i < nrow; i++) {
double covar = covars(i,j);
if (covar == 0.0) {
n0 += 1;
outcomes0 += outcome(i);
} else {
n1 += 1;
outcomes1 += outcome(i);
}
}
double prev1 = outcomes1/n1;
double prev0 = outcomes0/n0;
double rr = prev1/prev0;
out(j) = rr;
}
return out;
}
// @export
// [[Rcpp::export]]
NumericMatrix cpp_pMatrix(const NumericMatrix& ExpressionSet,const NumericVector& AgeVector)
{
int nRows = ExpressionSet.nrow();
int nCols = ExpressionSet.ncol();
NumericMatrix results(nRows,nCols);
NumericVector DivisorVector(nCols);
for(int stage = 0; stage < nCols; stage++) {
double divisor = 0;
for(int gene = 0; gene < nRows; gene++) {
divisor += ExpressionSet(gene, stage);
}
DivisorVector[stage] = divisor;
}
for(int stage = 0; stage < nCols; stage++){
for(int gene = 0; gene < nRows; gene++){
results(gene,stage) = (double) AgeVector[gene] * (ExpressionSet(gene, stage)/DivisorVector[stage]);
}
}
return results;
}
// [[Rcpp::export]]
NumericMatrix imp_neighbour_avg(NumericMatrix x, double k) {
// input matrix is expected to have >= 3 columns
NumericMatrix ans = clone(x);
int nr = ans.nrow(), nc = ans.ncol();
for(int i = 0; i < nr; i++) {
// first and last values are set to 0 if NA
if (R_IsNA(ans(i, 0))) ans(i, 0) = k;
if (R_IsNA(ans(i, nc-1))) ans(i, nc-1) = k;
for(int j = 1; j < (nc-1); j++) {
if (R_IsNA(ans(i,j))) {
// if the next value is NA and all previous values are 0
// then we set to 0
if (R_IsNA(ans(i,j+1))) {
NumericVector v = subset(ans.row(i), j);
if (allZero(v, k)) ans(i,j) = k;
} else { // next is not NA, set to mean of neighbours
ans(i,j) = (ans(i,j-1) + ans(i,j+1))/2;
}
}
}
}
return(ans);
}
// [[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;
}
}
// [[Rcpp::export]]
NumericMatrix neighbourhood(NumericMatrix x, NumericMatrix wdist, int state) {
/*
x = input grid matrix
y = output grid matrix
wdist = weights of distance matrix
state = value to check for
*/
int n = x.nrow();
int m = x.ncol();
int ndist = wdist.nrow();
int d = floor(ndist/2);
NumericMatrix y(n,m);
for (int i = 0; i < n; i++) {
for (int j = 0; j < m; j++) {
if(x(i,j) == state) { // abort if not occupied
for (int ii = imax(-d, -i); ii <= imin(n - i, d); ii++) {
for (int jj = imax(-d, -j); jj <= imin(m - j, d); jj++) {
if(isInside(n,m,i+ii,j+jj)) {
y((i + ii),(j + jj)) += wdist((ii + d), (jj + d));
}
}
}
}
}
}
return(y);
}
// [[Rcpp::export]]
NumericVector checktype_cpp(List rasterbands) {
// out[0]: is integer
// out[1]: has negative
// out[2]: max abs value
NumericVector out(3);
out[0] = 1;
double maxval = 0;
int counter = 0;
int nbands = rasterbands.size();
for (int i = 0; i < nbands; i++) {
NumericMatrix thisband = rasterbands[i];
int size = thisband.nrow()*thisband.ncol();
for (int j = 0; j < size; j++) {
double val = thisband[j];
if (fmod(val, 1) != 0) {
out[0] = 0;
}
if ((counter == 0) || (abs(val) > maxval)) {
maxval = val;
}
if (val < 0) {
out[1] = 1;
}
counter++;
}
}
out[2] = maxval;
return out;
}
