//---------------------------------------------------------------------
//
//---------------------------------------------------------------------
// [[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;
}
// **********************************************************//
// Calculate mu matrix for document d //
// **********************************************************//
// [[Rcpp::export]]
NumericVector mu_vec(arma::vec p_d, NumericMatrix xi) {
int nIP = xi.ncol();
NumericVector muvec(xi.nrow());
for (int IP = 0; IP < nIP; IP++) {
double pdIP = p_d[IP];
for (int i = 0; i < xi.nrow(); i++) {
if (pdIP > 0) {
muvec[i] += p_d[IP]*xi(i,IP);
}
}
}
return muvec;
}
// [[Rcpp::export]]
NumericMatrix rcpp_parallel_js_distance(NumericMatrix mat) {
// allocate the matrix we will return
NumericMatrix rmat(mat.nrow(), mat.nrow());
// create the worker
JsDistance jsDistance(mat, rmat);
// call it with parallelFor
parallelFor(0, mat.nrow(), jsDistance);
return rmat;
}
// [[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]]
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 gemmFitRcppI(int n, NumericMatrix betas, NumericMatrix data, int p, NumericVector kCor, CharacterVector correction, bool isTauB) {
NumericVector fit;
NumericVector fitR(betas.nrow()), fitTauA(betas.nrow()), fitTauB(betas.nrow()), fitBIC(betas.nrow()), fitBICr(betas.nrow()), fitAIC(betas.nrow()), fitAICr(betas.nrow());
NumericVector fitTauPairs(betas.nrow()), fitTauTies1(betas.nrow()), fitTauTies2(betas.nrow());
NumericVector fitTauTiesBoth(betas.nrow()), fitTauDis(betas.nrow()), fitTauCon(betas.nrow());
NumericMatrix data2(clone(data));
bool corType;
/*std::string s_targetname = as<std::string>(targetname)
*/
(as<std::string>(correction)=="knp") ? (corType=true) : (corType=false);
for (int i=0; i < betas.nrow(); i++) {
fit = gemmFitRcpp(n, betas(i,_), data2, p, kCor(i), corType, isTauB);
fitBIC(i) = fit[1];
fitBICr(i) = fit[2];
fitR(i) = fit[0];
fitAIC(i) = fit[4];
fitAICr(i) = fit[5];
fitTauA(i) = fit[6];
fitTauB(i) = fit[7];
fitTauPairs(i) = fit[8];
fitTauTies1(i) = fit[9];
fitTauTies2(i) = fit[10];
fitTauTiesBoth(i) = fit[11];
fitTauDis(i) = fit[12];
fitTauCon(i) = fit[13];
}
return Rcpp::List::create(Rcpp::Named("r") = fitR,
Rcpp::Named("bic") = fitBIC,
Rcpp::Named("tau.a") = fitTauA,
Rcpp::Named("tau.b") = fitTauB,
Rcpp::Named("tau.n.pairs") = fitTauPairs,
Rcpp::Named("tau.n.ties.1") = fitTauTies1,
Rcpp::Named("tau.n.ties.2") = fitTauTies2,
Rcpp::Named("tau.n.ties.both") = fitTauTiesBoth,
Rcpp::Named("tau.n.dis") = fitTauDis,
Rcpp::Named("tau.n.con") = fitTauCon,
Rcpp::Named("bic.r") = fitBICr,
Rcpp::Named("aic") = fitAIC,
Rcpp::Named("aic.r") = fitAICr);
}
// 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;
}
//' 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);
}
void CalculateProbabilities(
NumericMatrix & Foods,
NumericVector & fitness,
NumericVector & prob
) {
double maxfit = fitness[0];
for (int i=0;i<Foods.nrow();i++)
if (fitness[i] > maxfit) maxfit = fitness[i];
for (int i=0;i<Foods.nrow();i++)
prob[i] = (0.9*((fitness[i] + 1e-40)/(maxfit + 1e-40))) + 0.1;
return;
}
// **********************************************************//
// Multiply list of matrix X and list of vector B //
// **********************************************************//
// [[Rcpp::export]]
List MultiplyXB(List X, NumericMatrix B){
List XB(B.nrow());
for (int IP = 0; IP < B.nrow(); IP++) {
arma::mat XB_IP(X.size(), X.size());
arma::vec B_IP = B(IP, _);
for (unsigned int n = 0; n < X.size(); n++) {
List X_n = X[n];
arma::mat X_n_IP = X_n[IP];
arma::vec rows = X_n_IP*B_IP;
XB_IP.row(n) = rows.t();
}
XB[IP] = XB_IP;
}
return XB;
}
// [[Rcpp::export]]
NumericVector hazr(double t, double m, double bm, double bt, NumericMatrix dat){
// MAKE SURE dat IS SORTED BY TIME OR THIS FUNCTION WILL NOT WORK!!!
// bm should be on marker scale
// bt should be on time scale
// ---------------------------------------------------------------------------
NumericVector out(2);
// Collect subset of observations in marker trip in mstrip
// ---------------------------------------------------------------------------
int j = 0; // number of values in marker strip
NumericMatrix mstrip(dat.nrow(), 2); // put obsevations in marker strip here
for (int i = 0; i < dat.nrow(); i++){
// populate mstrip with observations
if ((dat(i, 2) < m+bm) && (dat(i,2) > m-bm)){
mstrip(j, 0) = dat(i, 0);
mstrip(j, 1) = dat(i, 1);
j += 1;
}
}
if (j == 0) return(out);
// - Do the local-in-marker hazard and N-A calculations
// ---------------------------------------------------------------------------
NumericVector na(j); // create vector for local N-A estimates
double nac = 0; // holder for N-A contributions
na[0] = mstrip(0, 1)/j; // N-A estimate at earliest time in strip
if (fabs(t - mstrip(0, 0)) <= bt){
// if first value is close enough to t, include in hazard calculation
out[0] = na[0];
out[1] = na[0]; // set N-A estimator
}
for (int i = 1; i < j; i++){
// include rest of qualified observations into hazard calculation
// calculate remaining N-A estimates
nac = (mstrip(i, 1)/(j - i)); // censoring indicat. divided by risk set size
na[i] = na[i-1] + nac;
if (fabs(t - mstrip(i, 0)) <= bt){
// if close enough to t, include in hazard calculation
out[0] += nac;
}
if (t >= mstrip(i, 0)){
// if we have reached t, return this for N-A estimate
out[1] = na[i];
}
}
out[0] = out[0]/(2*bt);
return(out);
}
// [[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);
}
// @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]]
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;
}
}
void Chain_Factorial::update_mu(NumericMatrix Y){
double alpha0 = 1.0/K;
//fit_linear_model(X, y, n, K, mu);
//fit_Bayesian_linear_model(X, y, n, K, mu, sigma);
NumericVector w_i, u_i, y_i;
for(int i=0; i<Y.nrow(); i++){
w_i = w(i, _);
u_i = u(i, _);
y_i = Y(i, _);
lambdas = calculate_mean_for_all_t(X, w_i, h, K, n);
double logprob_current = calculate_posterior_prob(y_i, lambdas, w_i, alpha0, K, n);
// propose a new alpha
// double alpha_proposed = random_walk_log_scale(alpha0, 0.3);
// propose a new w
NumericVector w_unnorm_proposed = RWMH(u_i, K, 0.5);
NumericVector w_proposed = w_unnorm_proposed / sum(w_unnorm_proposed);
NumericVector lambdas_proposed = calculate_mean_for_all_t(X, w_proposed, h, K, n);
double logprob_proposed = calculate_posterior_prob(y_i, lambdas_proposed, w_proposed, alpha0, K, n);
//printf("current %f, proposed %f, accept prob: %f\n\n", logprob_current, logprob_proposed, exp(logprob_proposed - logprob_current));
// accept or reject
if(R::runif(0, 1) < exp(logprob_proposed - logprob_current)){
u(i, _) = clone(w_unnorm_proposed);
w(i, _) = clone(w_proposed);
}
}
}
//[[Rcpp::export]]
NumericMatrix sigmoid(NumericMatrix mat) {
int m = mat.nrow();
int n = mat.ncol();
NumericMatrix res(m, n);
double x;
double z;
for (int i = 0; i < m; i++)
for (int j = 0; j < n; j++) {
x = mat(i, j);
if (x >= 0) {
z = exp(-x);
res(i, j) = 1 / (1 + z);
} else {
z = exp(x);
res(i, j) = z / (1 + z);
}
}
return res;
}
// [[Rcpp::export]]
List getFractionOfPointsNearBoundingBoxCPP(NumericMatrix coords, double distanceFraction) {
std::vector<double> range_x = computeRangeForDimension(coords, 0);
std::vector<double> range_y = computeRangeForDimension(coords, 1);
double distance_x = (range_x[1] - range_x[0]) * distanceFraction;
double distance_y = (range_y[1] - range_y[0]) * distanceFraction;
double x_min = range_x[0] + distance_x;
double y_min = range_y[0] + distance_y;
double x_max = range_x[1] - distance_x;
double y_max = range_y[1] - distance_y;
int n_cities = coords.nrow();
double n_out_of_bounds = 0;
for (int i = 0; i < n_cities; ++i) {
if (coords(i, 0) < x_min || coords(i, 0) > x_max || coords(i, 1) < y_min || coords(i, 1) > y_max) {
n_out_of_bounds += 1;
}
}
// ugly old-school C++ way to convert double to string
std::ostringstream os;
os << distanceFraction;
std::string distanceFractionString = os.str();
std::string feature_name = "fraction_of_nodes_outside_near_bounding_box_" + distanceFractionString;
return List::create(
_[feature_name] = NumericVector::create(n_out_of_bounds / n_cities)
);
}
MaxoutUnit(NumericMatrix activations, NumericMatrix derivatives,
const int poolSize, const NumericVector dropoutMask)
: activations(activations), derivatives(derivatives),
dropoutMask(dropoutMask), poolSize(poolSize)
{
colLength = activations.nrow();
}
void apply_repulsion(const NumericMatrix &lay, NumericMatrix &dvec, const NumericVector &mass, const NumericVector &nodes_size, double krep, bool prevent_overlap)
{
unsigned int nrow = lay.nrow();
for(unsigned int i = 0; i < (nrow - 1); i++)
for(unsigned int j = i + 1; j < nrow; j++)
{
float square_dist = (lay(i, 0) - lay(j, 0)) * (lay(i, 0) - lay(j, 0)) +
(lay(i, 1) - lay(j, 1)) * (lay(i, 1) - lay(j, 1));
float mass_prod = mass[i] * mass[j];
float f_rep = krep * (mass_prod / square_dist);
if(prevent_overlap)
{
float dist = sqrt(square_dist) - (nodes_size[i] + nodes_size[j]);
if(dist < 0)
f_rep = 100 * krep * mass_prod;
else
f_rep = krep * (mass_prod / (dist * dist));
}
dvec(i, 0) += (lay(i, 0) - lay(j, 0)) * f_rep;
dvec(i, 1) += (lay(i, 1) - lay(j, 1)) * f_rep;
dvec(j, 0) += (lay(j, 0) - lay(i, 0)) * f_rep;
dvec(j, 1) += (lay(j, 1) - lay(i, 1)) * f_rep;
}
}
NumericMatrix prepara_J (NumericMatrix x){
int i, j, k, V;
V = x.nrow();
NumericMatrix J = clone(x);
NumericVector K(V);
double m = 0;
for(i = 0; i < V; i++)
for(j = 0; j < V; j++){
K[i] = 0;
}
for (i = 0; i < V; i++)
for( j = 0; j < V; j++)
J(i,j) /= sqrt(J(i,i)*J(j,j));
for(i = 0; i < V; i++){
for(j = 0; j < V; j++){
J(i,i) = 0;
J(j,j) = 0;
K[i] += J(i,j);
}
m += K[i];
}
for( i = 0; i < V; i++){
for( j = 0; j < V; j++){
J(i,j) = J(i,j) - (K[i]*K[j])/(2*m);
}
}
return J;
}
// Function to calculate squared distance matrix (written by Jonathan Olmsted, NPD Group)
// [[Rcpp::export]]
NumericMatrix calcPWDh (NumericMatrix x)
{
int nrows = x.nrow() ;
int ncols = x.nrow() ;
NumericMatrix out(nrows, ncols) ;
double rad = 3963.1676 ;
double pi = 3.141592653589793238463 ;
for(int arow = 0; arow < nrows; arow++) {
for(int acol = 0; acol < ncols; acol++) {
double phi1 = x(arow, 0) * pi / 180 ;
double phi2 = x(acol, 0) * pi / 180 ;
double lambda1 = x(arow, 1) * pi / 180 ;
double lambda2 = x(acol, 1) * pi / 180;
double q1 = 2 * rad ;
double q2 = pow(sin((phi1 - phi2) / 2), 2) ;
double q3 = pow(sin((lambda1 - lambda2) / 2), 2) ;
double q4 = cos(phi1) * cos(phi2) ;
out(arow, acol) = q1 * asin(sqrt(q2 + q4 * q3)) ;
}
}
return out;
}
// [[Rcpp::export]]
void max_iter_brute_force(NumericMatrix xPoints_mat,
int k,
std::string solver_dir,
std::string log_dir) {
const int nPoints = xPoints_mat.ncol();
const int n = xPoints_mat.nrow();
user_function_data ui_data;
ui_data.k = k;
ui_data.param_prefix = "max_iter";
ui_data.solver_dir = solver_dir;
ui_data.log_dir = log_dir;
NumericVector row = xPoints_mat(0, _);
double min_f = std::numeric_limits<double>::infinity();
int min_x = 0;
double this_f;
for (int j = 0; j < nPoints; ++j) {
this_f = cv_error_function(n, &row[j], NULL, &ui_data);
std::cout << "x = " << row[j] << ": f = " << this_f << std::endl;
if (this_f < min_f) {
min_x = row[j];
min_f = this_f;
}
}
std::cout << "min x = " << min_x <<": achieves f = " << min_f << std::endl;
}
// **********************************************************//
// Calculate xi over the entire corpus //
// **********************************************************//
// [[Rcpp::export]]
List xi_all(NumericMatrix timemat, NumericMatrix eta1,NumericMatrix eta2, IntegerVector edgetrim) {
List xi(timemat.nrow());
for (IntegerVector::iterator it = edgetrim.begin(); it != edgetrim.end(); ++it) {
xi[*it-1] = ximat(timemat(*it-2, _), eta1, eta2);
}
return xi;
}
// [[Rcpp::export(name = ".doBilinear")]]
NumericVector doBilinear(NumericMatrix xy, NumericMatrix x, NumericMatrix y, NumericMatrix v) {
size_t len = v.nrow();
NumericVector result(len);
for (size_t i = 0; i < len; i++) {
double left = x(0,i);
double right = x(1,i);
double top = y(1,i);
double bottom = y(0,i);
double horiz = xy(i,0);
double vert = xy(i,1);
double denom = (right - left) * (top - bottom);
double bottomLeftValue = v(i,0) / denom;
double topLeftValue = v(i,1) / denom;
double topRightValue = v(i,3) / denom;
double bottomRightValue = v(i,2) / denom;
result[i] = bottomLeftValue*(right-horiz)*(top-vert) + bottomRightValue*(horiz-left)*(top-vert) +
topLeftValue*(right-horiz)*(vert-bottom) + topRightValue*(horiz-left)*(vert-bottom);
}
return result;
}
// @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 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;
}
// [[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;
}
// [[Rcpp::export]]
NumericVector gradlikCD(NumericVector parm, NumericMatrix Dmat, NumericVector x) {
int nsub = Dmat.nrow(), J = Dmat.ncol() - 1, i, j;
NumericVector Deriv(J + 1), parm1(J+1);
double denom, temp;
parm1[0] = parm[0];
parm1[1] = parm[1];
for (i = 2; i < J +1; i++) {
parm1[i] = parm1[i-1] + parm[i];
}
for (i = 0; i < nsub; ++i) {
denom = Dmat(i, 0);
for (j = 1; j < J+1; ++j) {
denom += Dmat(i, j)*exp(-exp(x[i]*parm1[0] + parm1[j]));
}
for (j = 1; j < J+1; ++j) {
temp = Dmat(i, j)*exp(-exp(x[i]*parm1[0] + parm1[j]))*exp(x[i]*parm1[0] + parm1[j]);
Deriv[0] += temp*x[i]/denom;
Deriv[j] += temp/denom;
}
}
for (j=J-1; j>0; j--) {
Deriv[j] = Deriv[j] + Deriv[j+1];
}
return Deriv;
}
// [[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 row_weights(NumericMatrix x, NumericVector weight) {
int nX = x.ncol();
int nY = x.nrow();
NumericVector v = no_init(nY);
#pragma omp parallel for schedule(static)
for (int i=0; i < nY; i++) {
NumericMatrix::Row row = x(i, _);
double w = 0;
for (int j=0; j < nX; j++) {
if(row[j]!=0 && !R_IsNA(row[j])) {
w += weight[j];
}
}
double o = 0;
if (w!=0) {
for(int j=0; j < nX; j++) {
if(row[j]!=0 && !R_IsNA(row[j])) {
o += row[j]*weight[j] / w;
}
}
}
v[i] = o;
}
v.attr("names") = rownames(x);
return v;
}
