// [[Rcpp::export]]
Rcpp::List worstcase_l1(Rcpp::NumericVector z, Rcpp::NumericVector q, double t){
// resulting probability
craam::numvec p;
// resulting objective value
double objective;
craam::numvec vz(z.begin(), z.end()), vq(q.begin(), q.end());
std::tie(p,objective) = craam::worstcase_l1(vz,vq,t);
Rcpp::List result;
result["p"] = Rcpp::NumericVector(p.cbegin(), p.cend());
result["obj"] = objective;
return result;
}
//' rcpp_neutral_hotspots_ntests
//'
//' Performs repeated neutral tests to yield average distributions of both
//' hotspot values and spatial autocorrelation statistics.
//'
//' @param nbs An \code{spdep} \code{nb} object listing all neighbours of each
//' point.
//' @param wts Weighting factors for each neighbour; must have same length as
//' nbs.
//' @param nbsi List of matrices as returned from \code{get_nbsi}. each element
//' of which contains the i-th nearest neighbour to each point.
//' @param alpha Strength of spatial autocorrelation
//' @param sd0 Standard deviation of truncated normal distribution used to model
//' environmental variation (with mean of 1)
//' @param nt Number of successive layers of temporal and spatial autocorrelation
//' used to generate final modelled values
//' @param ntests Number of tests used to obtain average values
//' @param ac_type Character string specifying type of aucorrelation
//' (\code{moran}, \code{geary}, or code{getis-ord}).
//'
//' @return A matrix of dimension (size, 2), with first column containing
//' sorted and re-scaled hotspot values, and second column containing sorted and
//' re-scaled spatial autocorrelation statistics.
//'
// [[Rcpp::export]]
Rcpp::NumericMatrix rcpp_neutral_hotspots_ntests (Rcpp::List nbs,
Rcpp::List wts, Rcpp::List nbsi, double alpha, double sd0, int niters,
std::string ac_type, bool log_scale, int ntests)
{
const int size = nbs.size ();
Rcpp::NumericMatrix hs1;
Rcpp::NumericVector z (size), z1 (size), ac (size), ac1 (size);
std::fill (ac.begin (), ac.end (), 0.0);
std::fill (z.begin (), z.end (), 0.0);
for (int n=0; n<ntests; n++)
{
hs1 = rcpp_neutral_hotspots (nbs, wts, nbsi, alpha, sd0, log_scale,
niters, ac_type);
z += hs1 (Rcpp::_, 0);
ac += hs1 (Rcpp::_, 1);
}
Rcpp::NumericMatrix result (size, 2);
result (Rcpp::_, 0) = z / (double) ntests;
result (Rcpp::_, 1) = ac / (double) ntests;
Rcpp::colnames (result) = Rcpp::CharacterVector::create ("z", "ac");
return result;
}
// [[Rcpp::export]]
Rcpp::NumericVector randomSample(Rcpp::NumericVector a, int n) {
// clone a into b to leave a alone
Rcpp::NumericVector b(n);
__gnu_cxx::random_sample(a.begin(), a.end(),
b.begin(), b.end(), randWrapper);
return b;
}
void eigs_sym_shift_c(
mat_op op, int n, int k, double sigma,
const spectra_opts *opts, void *data,
int *nconv, int *niter, int *nops,
double *evals, double *evecs, int *info
)
{
BEGIN_RCPP
CRealShift cmat_op(op, n, data);
Rcpp::List res;
try {
res = run_eigs_shift_sym((RealShift*) &cmat_op, n, k, opts->ncv, opts->rule,
sigma, opts->maxitr, opts->tol, opts->retvec != 0);
*info = 0;
} catch(...) {
*info = 1; // indicates error
}
*nconv = Rcpp::as<int>(res["nconv"]);
*niter = Rcpp::as<int>(res["niter"]);
*nops = Rcpp::as<int>(res["nops"]);
Rcpp::NumericVector val = res["values"];
std::copy(val.begin(), val.end(), evals);
if(opts->retvec != 0)
{
Rcpp::NumericMatrix vec = res["vectors"];
std::copy(vec.begin(), vec.end(), evecs);
}
VOID_END_RCPP
}
double lmerResp::updateMu(const Rcpp::NumericVector& gamma) {
#ifdef USE_RCPP_SUGAR
d_mu = d_offset + gamma;
#else
std::transform(gamma.begin(), gamma.end(), d_offset.begin(),
d_mu.begin(), std::plus<double>());
#endif
return updateWrss();
}
// kernel Dist function on a Grid
// [[Rcpp::export]]
Rcpp::NumericVector
KdeDist(const Rcpp::NumericMatrix & X
, const Rcpp::NumericMatrix & Grid
, const double h
, const Rcpp::NumericVector & weight
, const bool printProgress
) {
const unsigned sampleNum = X.nrow();
const unsigned dimension = Grid.ncol();
const unsigned gridNum = Grid.nrow();
// first = sum K_h(X_i, X_j), second = K_h(x, x), third = sum K_h(x, X_i)
std::vector< double > firstValue;
const double second = 1.0;
std::vector< double > thirdValue;
double firstmean;
Rcpp::NumericVector kdeDistValue(gridNum);
int counter = 0, percentageFloor = 0;
int totalCount = sampleNum + gridNum;
if (printProgress) {
printProgressFrame(Rprintf);
}
firstValue = computeKernel< std::vector< double > >(
X, X, h, weight, printProgress, Rprintf, counter, totalCount,
percentageFloor);
if (dimension <= 1) {
thirdValue = computeKernel< std::vector< double > >(
X, Grid, h, weight, printProgress, Rprintf, counter, totalCount,
percentageFloor);
}
else {
thirdValue = computeGaussOuter< std::vector< double > >(
X, Grid, h, weight, printProgress, Rprintf, counter, totalCount,
percentageFloor);
}
if (weight.size() == 1) {
firstmean = std::accumulate(firstValue.begin(), firstValue.end(), 0.0) / sampleNum;
}
else {
firstmean = std::inner_product(
firstValue.begin(), firstValue.end(), weight.begin(), 0.0) /
std::accumulate(weight.begin(), weight.end(), 0.0);
}
for (unsigned gridIdx = 0; gridIdx < gridNum; ++gridIdx) {
kdeDistValue[gridIdx] = std::sqrt(firstmean + second - 2 * thirdValue[gridIdx]);
}
if (printProgress) {
Rprintf("\n");
}
return kdeDistValue;
}
// Calculate lk, k=1, ..., M with m0=0;
// where h=(h0, h1, ..., hM) with h0=0 and d=(d0, d1, ..., dM) with d0=0, dM=R_PosInf
void Getlk(Rcpp::NumericVector& lk, const Rcpp::IntegerVector& Mt, int M1, Rcpp::NumericVector d,
const Rcpp::NumericVector& t, const Rcpp::NumericVector& Xbeta){
int n = Mt.size();
std::fill(lk.begin(), lk.end(), 0);
for (int k=1; k<M1; ++k){
for (int i=0; i<n; ++i){
if(Mt[i]>=k) lk[k] += (std::min(d[k],t[i])-d[k-1])*std::exp(Xbeta[i]);
}
}
}
// [[Rcpp::export]]
double trapzRcpp(const Rcpp::NumericVector X, const Rcpp::NumericVector Y){
if( Y.size() != X.size()){
Rcpp::stop("The input Y-grid does not have the same number of points as input X-grid.");
}
if(is_sorted(X.begin(),X.end())){
double trapzsum = 0;
for (unsigned int ind = 0; ind != X.size()-1; ++ind){
trapzsum += 0.5 * (X[ind + 1] - X[ind]) *(Y[ind] + Y[ind + 1]);
}
return trapzsum;
} else {
Rcpp::stop("The input X-grid is not sorted.");
return std::numeric_limits<double>::quiet_NaN();
}
return std::numeric_limits<double>::quiet_NaN();
}
SEXP conditionalPoissonSecondInclusion(SEXP sizes_sexp, SEXP n_sexp)
{
BEGIN_RCPP
Rcpp::NumericVector sizes = Rcpp::as<Rcpp::NumericVector>(sizes_sexp);
int n = Rcpp::as<int>(n_sexp);
conditionalPoissonArgs args;
args.weights.insert(args.weights.begin(), sizes.begin(), sizes.end());
args.n = n;
std::vector<mpfr_class> inclusionProbabilities;
args.zeroWeights.resize(sizes.size());
args.deterministicInclusion.resize(sizes.size());
args.indices.clear();
for(int i = 0; i != sizes.size(); i++)
{
args.zeroWeights[i] = args.deterministicInclusion[i] = false;
if(sizes[i] < 0 || sizes[i] > 1)
{
throw std::runtime_error("Sizes must be values in [0, 1]");
}
else if(sizes[i] == 0)
{
args.zeroWeights[i] = true;
}
else if(sizes[i] == 1)
{
args.deterministicInclusion[i] = true;
args.indices.push_back(i);
}
}
computeExponentialParameters(args);
conditionalPoissonInclusionProbabilities(args, inclusionProbabilities);
boost::numeric::ublas::matrix<mpfr_class> secondOrder(sizes.size(), sizes.size());
conditionalPoissonSecondOrderInclusionProbabilities(args, inclusionProbabilities, secondOrder);
Rcpp::NumericMatrix result(sizes.size(), sizes.size());
for(int i = 0; i < sizes.size(); i++)
{
for(int j = 0; j < sizes.size(); j++)
{
result(i, j) = secondOrder(i, j).convert_to<double>();
}
}
return result;
END_RCPP
}
/**
* Check and install new value of theta. Update Lambda.
*
* @param nt New value of theta
*/
void reModule::setTheta(const Rcpp::NumericVector& nt)
throw (std::runtime_error) {
R_len_t nth = d_lower.size(), nLind = d_Lind.size();
if (nt.size() != nth)
throw runtime_error("setTheta: size mismatch of nt and d_lower");
#ifdef USE_RCPP_SUGAR
if (any(nt < d_lower).is_true()) // check that nt is feasible
throw runtime_error("setTheta: theta not in feasible region");
#else
double *lp = d_lower.begin(), *ntp = nt.begin();
for (R_len_t i = 0; i < nth; i++)
if (ntp[i] < lp[i])
throw runtime_error("setTheta: theta not in feasible region");
#endif
copy(nt.begin(), nt.end(), d_theta.begin());
// update Lambda from theta and Lind
double *Lamx = (double*)d_Lambda.x, *th = d_theta.begin();
int *Li = d_Lind.begin();
for (R_len_t i = 0; i < nLind; i++) Lamx[i] = th[Li[i] - 1];
}
SEXP conditionalPoissonInclusion(SEXP sizes_sexp, SEXP n_sexp)
{
BEGIN_RCPP
Rcpp::NumericVector sizes = Rcpp::as<Rcpp::NumericVector>(sizes_sexp);
int n = Rcpp::as<int>(n_sexp);
conditionalPoissonArgs args;
args.weights.insert(args.weights.begin(), sizes.begin(), sizes.end());
args.n = n;
std::vector<mpfr_class> inclusionProbabilities;
args.zeroWeights.resize(sizes.size());
args.deterministicInclusion.resize(sizes.size());
args.indices.clear();
for(int i = 0; i != sizes.size(); i++)
{
args.zeroWeights[i] = args.deterministicInclusion[i] = false;
if(sizes[i] < 0 || sizes[i] > 1)
{
throw std::runtime_error("Sizes must be values in [0, 1]");
}
else if(sizes[i] == 0)
{
args.zeroWeights[i] = true;
}
else if(sizes[i] == 1)
{
args.deterministicInclusion[i] = true;
args.indices.push_back(i);
}
}
computeExponentialParameters(args);
conditionalPoissonInclusionProbabilities(args, inclusionProbabilities);
std::vector<double> inclusionProbabilities_double;
std::transform(inclusionProbabilities.begin(), inclusionProbabilities.end(), std::back_inserter(inclusionProbabilities_double), [](mpfr_class x){ return x.convert_to<double>(); });
return Rcpp::wrap(inclusionProbabilities_double);
END_RCPP
}
double nlmerResp::updateMu(Rcpp::NumericVector const &gamma) throw(std::runtime_error) {
int n = d_y.size();
#ifdef USE_RCPP_SUGAR
Rcpp::NumericVector gam = gamma + d_offset;
#else
NumericVector gam(d_offset.size());
std::transform(gamma.begin(), gamma.end(), d_offset.begin(),
gam.begin(), std::plus<double>());
#endif
double *gg = gam.begin();
for (int p = 0; p < d_pnames.size(); p++) {
std::string pn(d_pnames[p]);
Rcpp::NumericVector pp = d_nlenv.get(pn);
std::copy(gg + n * p, gg + n * (p + 1), pp.begin());
}
NumericVector rr = d_nlmod.eval(SEXP(d_nlenv));
if (rr.size() != n)
throw std::runtime_error("dimension mismatch");
std::copy(rr.begin(), rr.end(), d_mu.begin());
NumericMatrix rrg = rr.attr("gradient");
std::copy(rrg.begin(), rrg.end(), d_sqrtXwt.begin());
return updateWrss();
}
//' rcpp_trunc_ndist
//'
//' Truncated normal distribution (mean 1, respective upper and lower limits of
//' 0 and 2). Code copied directly from `github.com/mpadge/tnorm`, with the
//' readme of that repo demonstrating the speed advantages of using this rather
//' than pre-existing approaches (the R package `truncnorm`).
//'
//' @param len Number of elements to be simulated
//' @param sd Standard deviation
//'
//' @return A vector of truncated normally distributed values
//'
// [[Rcpp::export]]
Rcpp::NumericVector rcpp_trunc_ndist (int len, double sd)
{
double tempd;
// Set up truncated normal distribution
Rcpp::NumericVector eps (len);
std::vector <double> z;
z.resize (0);
while (z.size () < len)
{
eps = Rcpp::rnorm (len, 1.0, sd);
for (Rcpp::NumericVector::iterator it = eps.begin ();
it != eps.end (); ++it)
if (*it >= 0.0 && *it <= 2.0)
z.push_back (*it);
}
z.resize (len);
std::copy (z.begin (), z.end (), eps.begin ());
z.resize (0);
return eps;
}
void vec_insert( vec* obj, int position, Rcpp::NumericVector data) {
vec::iterator it = obj->begin() + position;
obj->insert( it, data.begin(), data.end() );
}
// helpers
void vec_assign( vec* obj, Rcpp::NumericVector data) {
obj->assign( data.begin(), data.end() ) ;
}
double Util::vectorLengthManhatten(Rcpp::NumericVector x) {
Rcpp::NumericVector result;
result = abs(x);
double erg = std::accumulate(result.begin(),result.end(), 0.0);
return erg;
}
Rcpp::NumericVector
glmFamily::linkInv(Rcpp::NumericVector const &eta) const {
if (linvs.count(d_link))
return NumericVector::import_transform(eta.begin(), eta.end(), linvs[d_link]);
return d_linkinv(eta);
}
void reModule::setIncr (const Rcpp::NumericVector& ii)
throw (std::runtime_error) {
if (ii.size() != d_incr.size())
throw runtime_error("size mismatch");
copy(ii.begin(), ii.end(), d_incr.begin());
}
void lmerResp::setOffset(const Rcpp::NumericVector& oo)
throw (std::runtime_error) {
if (oo.size() != d_offset.size())
throw std::runtime_error("setOffset: Size mismatch");
std::copy(oo.begin(), oo.end(), d_offset.begin());
}
Rcpp::NumericVector
glmFamily::muEta(Rcpp::NumericVector const &eta) const {
if (muEtas.count(d_link))
return NumericVector::import_transform(eta.begin(), eta.end(), muEtas[d_link]);
return d_muEta(eta);
}
Rcpp::NumericVector
glmFamily::variance(Rcpp::NumericVector const &mu) const {
if (varFuncs.count(d_link))
return NumericVector::import_transform(mu.begin(), mu.end(), varFuncs[d_link]);
return d_variance(mu);
}
//' Map N(0,1) stochastic perturbations to an LNA path.
//'
//' @param pathmat matrix where the LNA path should be stored
//' @param draws matrix of N(0,1) draws to be mapped to an LNA path
//' @param lna_times vector of interval endpoint times
//' @param lna_pars numeric matrix of parameters, constants, and time-varying
//' covariates at each of the lna_times
//' @param init_start index in the parameter vector where the initial compartment
//' volumes start
//' @param param_update_inds logical vector indicating at which of the times the
//' LNA parameters need to be updated.
//' @param stoich_matrix stoichiometry matrix giving the changes to compartments
//' from each reaction
//' @param forcing_inds logical vector of indicating at which times in the
//' time-varying covariance matrix a forcing is applied.
//' @param forcing_matrix matrix containing the forcings.
//' @param svd_d vector in which to store SVD singular values
//' @param svd_U matrix in which to store the U matrix of the SVD
//' @param svd_V matrix in which to store the V matrix of the SVD
//' @param step_size initial step size for the ODE solver (adapted internally,
//' but too large of an initial step can lead to failure in stiff systems).
//' @param lna_pointer external pointer to LNA integration function.
//' @param set_pars_pointer external pointer to the function for setting the LNA
//' parameters.
//'
//' @return fill out pathmat with the LNA path corresponding to the stochastic
//' perturbations.
//'
//' @export
// [[Rcpp::export]]
void map_draws_2_lna(arma::mat& pathmat,
const arma::mat& draws,
const arma::rowvec& lna_times,
const Rcpp::NumericMatrix& lna_pars,
Rcpp::NumericVector& lna_param_vec,
const Rcpp::IntegerVector& lna_param_inds,
const Rcpp::IntegerVector& lna_tcovar_inds,
const int init_start,
const Rcpp::LogicalVector& param_update_inds,
const arma::mat& stoich_matrix,
const Rcpp::LogicalVector& forcing_inds,
const arma::uvec& forcing_tcov_inds,
const arma::mat& forcings_out,
const arma::cube& forcing_transfers,
arma::vec& svd_d,
arma::mat& svd_U,
arma::mat& svd_V,
double step_size,
SEXP lna_pointer,
SEXP set_pars_pointer) {
// get the dimensions of various objects
int n_events = stoich_matrix.n_cols; // number of transition events, e.g., S2I, I2R
int n_comps = stoich_matrix.n_rows; // number of model compartments (all strata)
int n_odes = n_events + n_events*n_events; // number of ODEs
int n_times = lna_times.n_elem; // number of times at which the LNA must be evaluated
int n_tcovar = lna_tcovar_inds.size(); // number of time-varying covariates or parameters
int n_forcings = forcing_tcov_inds.n_elem; // number of forcings
// for use with forcings
double forcing_flow = 0;
arma::vec forcing_distvec(n_comps, arma::fill::zeros);
// initialize the objects used in each time interval
double t_L = 0;
double t_R = 0;
// vector of parameters, initial compartment columes, constants, and time-varying covariates
std::copy(lna_pars.row(0).begin(), lna_pars.row(0).end(), lna_param_vec.begin());
CALL_SET_ODE_PARAMS(lna_param_vec, set_pars_pointer); // set the parameters in the odeintr namespace
// initial state vector - copy elements from the current parameter vector
arma::vec init_volumes(lna_param_vec.begin() + init_start, n_comps);
// initialize the LNA objects
bool good_svd = true;
Rcpp::NumericVector lna_state_vec(n_odes); // the vector for storing the current state of the LNA ODEs
arma::vec lna_drift(n_events, arma::fill::zeros); // incidence mean vector (log scale)
arma::mat lna_diffusion(n_events, n_events, arma::fill::zeros); // diffusion matrix
arma::vec log_lna(n_events, arma::fill::zeros); // LNA increment, log scale
arma::vec nat_lna(n_events, arma::fill::zeros); // LNA increment, natural scale
// apply forcings if called for - applied after censusing at the first time
if(forcing_inds[0]) {
// distribute the forcings proportionally to the compartment counts in the applicable states
for(int j=0; j < n_forcings; ++j) {
forcing_flow = lna_pars(0, forcing_tcov_inds[j]);
forcing_distvec = forcing_flow * normalise(forcings_out.col(j) % init_volumes, 1);
init_volumes += forcing_transfers.slice(j) * forcing_distvec;
}
}
// iterate over the time sequence, solving the LNA over each interval
for(int j=0; j < (n_times-1); ++j) {
// set the times of the interval endpoints
t_L = lna_times[j];
t_R = lna_times[j+1];
// Reset the LNA state vector and integrate the LNA ODEs over the next interval to 0
std::fill(lna_state_vec.begin(), lna_state_vec.end(), 0.0);
CALL_INTEGRATE_STEM_ODE(lna_state_vec, t_L, t_R, step_size, lna_pointer);
// transfer the elements of the lna_state_vec to the process objects
std::copy(lna_state_vec.begin(), lna_state_vec.begin() + n_events, lna_drift.begin());
std::copy(lna_state_vec.begin() + n_events, lna_state_vec.end(), lna_diffusion.begin());
// ensure symmetry of the diffusion matrix
lna_diffusion = arma::symmatu(lna_diffusion);
// map the stochastic perturbation to the LNA path on its natural scale
try{
if(lna_drift.has_nan() || lna_diffusion.has_nan()) {
good_svd = false;
throw std::runtime_error("Integration failed.");
} else {
good_svd = arma::svd(svd_U, svd_d, svd_V, lna_diffusion); // compute the SVD
}
if(!good_svd) {
throw std::runtime_error("SVD failed.");
} else {
svd_d.elem(arma::find(svd_d < 0)).zeros(); // zero out negative sing. vals
svd_V.each_row() %= arma::sqrt(svd_d).t(); // multiply rows of V by sqrt(d)
svd_U *= svd_V.t(); // complete svd_sqrt
svd_U.elem(arma::find(lna_diffusion == 0)).zeros(); // zero out numerical errors
log_lna = lna_drift + svd_U * draws.col(j); // map the LNA draws
}
} catch(std::exception & err) {
// reinstatiate the SVD objects
arma::vec svd_d(n_events, arma::fill::zeros);
arma::mat svd_U(n_events, n_events, arma::fill::zeros);
arma::mat svd_V(n_events, n_events, arma::fill::zeros);
// forward the exception
forward_exception_to_r(err);
} catch(...) {
::Rf_error("c++ exception (unknown reason)");
}
// compute the LNA increment
nat_lna = arma::vec(expm1(Rcpp::NumericVector(log_lna.begin(), log_lna.end())));
// save the LNA increment
pathmat(j+1, arma::span(1, n_events)) = nat_lna.t();
// update the initial volumes
init_volumes += stoich_matrix * nat_lna;
// if any increments or volumes are negative, throw an error
try{
if(any(nat_lna < 0)) {
throw std::runtime_error("Negative increment.");
}
if(any(init_volumes < 0)) {
throw std::runtime_error("Negative compartment volumes.");
}
} catch(std::runtime_error &err) {
forward_exception_to_r(err);
} catch(...) {
::Rf_error("c++ exception (unknown reason)");
}
// apply forcings if called for - applied after censusing the path
if(forcing_inds[j+1]) {
// distribute the forcings proportionally to the compartment counts in the applicable states
for(int s=0; s < n_forcings; ++s) {
forcing_flow = lna_pars(j+1, forcing_tcov_inds[s]);
forcing_distvec = forcing_flow * normalise(forcings_out.col(s) % init_volumes, 1);
init_volumes += forcing_transfers.slice(s) * forcing_distvec;
}
// throw errors for negative negative volumes
try{
if(any(init_volumes < 0)) {
throw std::runtime_error("Negative compartment volumes.");
}
} catch(std::exception &err) {
forward_exception_to_r(err);
} catch(...) {
::Rf_error("c++ exception (unknown reason)");
}
}
// update the parameters if they need to be updated
if(param_update_inds[j+1]) {
// time-varying covariates and parameters
std::copy(lna_pars.row(j+1).end() - n_tcovar,
lna_pars.row(j+1).end(),
lna_param_vec.end() - n_tcovar);
}
// copy the new initial volumes into the vector of parameters
std::copy(init_volumes.begin(), init_volumes.end(), lna_param_vec.begin() + init_start);
// set the lna parameters and reset the LNA state vector
CALL_SET_ODE_PARAMS(lna_param_vec, set_pars_pointer);
}
}
void densePred::setCoef0(const Rcpp::NumericVector& cc)
throw (std::runtime_error) {
if (cc.size() != d_coef0.size())
throw std::runtime_error("size mismatch in setCoef0");
std::copy(cc.begin(), cc.end(), d_coef0.begin());
}
Rcpp::NumericVector
glmFamily::linkFun(Rcpp::NumericVector const &mu) const {
if (lnks.count(d_link))
return NumericVector::import_transform(mu.begin(), mu.end(), lnks[d_link]);
return d_linkfun(mu);
}
void reModule::setU0 (const Rcpp::NumericVector& uu)
throw (std::runtime_error) {
if (uu.size() != d_u0.size())
throw runtime_error("size mismatch");
copy(uu.begin(), uu.end(), d_u0.begin());
}
SEXP hclustLodMatrix(SEXP mpcrossRF_, SEXP preClusterResults_)
{
BEGIN_RCPP
bool noDuplicates;
R_xlen_t preClusterMarkers = countPreClusterMarkers(preClusterResults_, noDuplicates);
if(!noDuplicates)
{
throw std::runtime_error("Duplicate marker indices in call to hclustThetaMatrix");
}
Rcpp::List preClusterResults = preClusterResults_;
Rcpp::S4 mpcrossRF = mpcrossRF_;
Rcpp::S4 rf = mpcrossRF.slot("rf");
Rcpp::RObject lodObject = rf.slot("lod");
if(lodObject.isNULL())
{
throw std::runtime_error("Slot mpcrossRF@rf@lod cannot be NULL if clusterBy is equal to \"combined\"");
}
Rcpp::S4 lod = Rcpp::as<Rcpp::S4>(lodObject);
Rcpp::NumericVector lodData = lod.slot("x");
if(lodData.size() != (preClusterMarkers*(preClusterMarkers+(R_xlen_t)1))/(R_xlen_t)2)
{
throw std::runtime_error("Number of markers in precluster object was inconsistent with number of markers in mpcrossRF object");
}
R_xlen_t resultDimension = preClusterResults.size();
double maxLod = *std::max_element(lodData.begin(), lodData.end());
//Allocate enough storage. This symmetric matrix stores the *LOWER* triangular part, in column-major storage. Excluding the diagonal.
Rcpp::NumericVector result(((resultDimension-(R_xlen_t)1)*resultDimension)/(R_xlen_t)2);
for(R_xlen_t column = 0; column < resultDimension; column++)
{
Rcpp::IntegerVector columnMarkers = preClusterResults(column);
for(R_xlen_t row = column + 1; row < resultDimension; row++)
{
Rcpp::IntegerVector rowMarkers = preClusterResults(row);
double total = 0;
int counter = 0;
for(R_xlen_t columnMarkerCounter = 0; columnMarkerCounter < columnMarkers.size(); columnMarkerCounter++)
{
R_xlen_t marker1 = columnMarkers[columnMarkerCounter]-(R_xlen_t)1;
for(R_xlen_t rowMarkerCounter = 0; rowMarkerCounter < rowMarkers.size(); rowMarkerCounter++)
{
R_xlen_t marker2 = rowMarkers[rowMarkerCounter]-(R_xlen_t)1;
R_xlen_t column = std::max(marker1, marker2);
R_xlen_t row = std::min(marker1, marker2);
double currentLodDataValue = lodData((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
if(currentLodDataValue != NA_REAL && currentLodDataValue == currentLodDataValue)
{
total += currentLodDataValue;
counter++;
}
}
}
if(counter == 0) total = maxLod;
else total /= counter;
result(((resultDimension-(R_xlen_t)1)*resultDimension)/(R_xlen_t)2 - ((resultDimension - column)*(resultDimension-column-(R_xlen_t)1))/(R_xlen_t)2 + row-column-(R_xlen_t)1) = maxLod - total;
}
}
return result;
END_RCPP;
}
void lmerResp::setWeights(const Rcpp::NumericVector& ww)
throw (std::runtime_error) {
if (ww.size() != d_weights.size())
throw std::runtime_error("setWeights: Size mismatch");
std::copy(ww.begin(), ww.end(), d_weights.begin());
}
SEXP hclustCombinedMatrix(SEXP mpcrossRF_, SEXP preClusterResults_)
{
BEGIN_RCPP
bool noDuplicates;
R_xlen_t preClusterMarkers = countPreClusterMarkers(preClusterResults_, noDuplicates);
if(!noDuplicates)
{
throw std::runtime_error("Duplicate marker indices in call to hclustThetaMatrix");
}
Rcpp::List preClusterResults = preClusterResults_;
Rcpp::S4 mpcrossRF = mpcrossRF_;
Rcpp::S4 rf = mpcrossRF.slot("rf");
Rcpp::RObject lodObject = rf.slot("lod");
if(lodObject.isNULL())
{
throw std::runtime_error("Slot mpcrossRF@rf@lod cannot be NULL if clusterBy is equal to \"combined\"");
}
Rcpp::S4 lod = Rcpp::as<Rcpp::S4>(lodObject);
Rcpp::S4 theta = rf.slot("theta");
Rcpp::RawVector data = theta.slot("data");
Rcpp::NumericVector levels = theta.slot("levels");
Rcpp::CharacterVector markers = theta.slot("markers");
Rcpp::NumericVector lodData = lod.slot("x");
if(markers.size() != preClusterMarkers || lodData.size() != (preClusterMarkers*(preClusterMarkers+(R_xlen_t)1))/(R_xlen_t)2)
{
throw std::runtime_error("Number of markers in precluster object was inconsistent with number of markers in mpcrossRF object");
}
R_xlen_t resultDimension = preClusterResults.size();
//Work out minimum difference between recombination levels
double minDifference = 1;
for(int i = 0; i < levels.size()-1; i++)
{
minDifference = std::min(minDifference, levels[i+1] - levels[i]);
}
double maxLod = *std::max_element(lodData.begin(), lodData.end());
double lodMultiplier = minDifference/maxLod;
//Allocate enough storage. This symmetric matrix stores the *LOWER* triangular part, in column-major storage. Excluding the diagonal.
Rcpp::NumericVector result(((resultDimension-(R_xlen_t)1)*resultDimension)/(R_xlen_t)2);
for(R_xlen_t column = 0; column < resultDimension; column++)
{
Rcpp::IntegerVector columnMarkers = preClusterResults(column);
for(R_xlen_t row = column + (R_xlen_t)1; row < resultDimension; row++)
{
Rcpp::IntegerVector rowMarkers = preClusterResults(row);
double total = 0;
R_xlen_t counter = 0;
for(int columnMarkerCounter = 0; columnMarkerCounter < columnMarkers.size(); columnMarkerCounter++)
{
R_xlen_t marker1 = columnMarkers[columnMarkerCounter]-(R_xlen_t)1;
for(int rowMarkerCounter = 0; rowMarkerCounter < rowMarkers.size(); rowMarkerCounter++)
{
R_xlen_t marker2 = rowMarkers[rowMarkerCounter]-(R_xlen_t)1;
R_xlen_t column = std::max(marker1, marker2);
R_xlen_t row = std::min(marker1, marker2);
Rbyte thetaDataValue = data((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
double currentLodDataValue = lodData((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
if(thetaDataValue != 0xFF && currentLodDataValue != NA_REAL && currentLodDataValue == currentLodDataValue)
{
total += levels(thetaDataValue) + (maxLod - currentLodDataValue) *lodMultiplier;
counter++;
}
}
}
if(counter == 0) total = 0.5 + minDifference;
else total /= counter;
result(((resultDimension-1)*resultDimension)/(R_xlen_t)2 - ((resultDimension - column)*(resultDimension-column-(R_xlen_t)1))/(R_xlen_t)2 + row-column-(R_xlen_t)1) = total;
}
}
return result;
END_RCPP
}
void addItem(int32_t item, Rcpp::NumericVector dv) {
std::vector<float> fv(dv.size());
std::copy(dv.begin(), dv.end(), fv.begin());
ptr->add_item(item, &fv[0]);
}
