SEXP assignRawSymmetricMatrixDiagonal(SEXP destination_, SEXP indices_, SEXP source_)
{
BEGIN_RCPP
Rcpp::S4 destination = destination_;
Rcpp::RawVector source = source_;
Rcpp::RawVector destinationData = destination.slot("data");
Rcpp::IntegerVector indices = indices_;
if(&(source(0)) == &(destinationData(0)))
{
throw std::runtime_error("Source and destination cannot be the same in assignRawSymmetricMatrixDiagonal");
}
if((indices.size()*(indices.size()+(R_xlen_t)1))/(R_xlen_t)2 != source.size())
{
throw std::runtime_error("Mismatch between index length and source object size");
}
for(R_xlen_t column = 0; column < indices.size(); column++)
{
for(R_xlen_t row = 0; row <= column; row++)
{
R_xlen_t rowIndex = indices[row];
R_xlen_t columnIndex = indices[column];
if(rowIndex > columnIndex)
{
std::swap(rowIndex, columnIndex);
}
destinationData((columnIndex*(columnIndex-(R_xlen_t)1))/(R_xlen_t)2+rowIndex-(R_xlen_t)1) = source((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
}
}
END_RCPP
}
// [[Rcpp::export]]
Rcpp::RawVector magick_image_write( XPtrImage input, Rcpp::CharacterVector format, Rcpp::IntegerVector quality,
Rcpp::IntegerVector depth, Rcpp::CharacterVector density, Rcpp::CharacterVector comment){
if(!input->size())
return Rcpp::RawVector(0);
XPtrImage image = copy(input);
#if MagickLibVersion >= 0x691
//suppress write warnings see #74 and #116
image->front().quiet(true);
#endif
if(format.size())
for_each ( image->begin(), image->end(), Magick::magickImage(std::string(format[0])));
if(quality.size())
for_each ( image->begin(), image->end(), Magick::qualityImage(quality[0]));
if(depth.size())
for_each ( image->begin(), image->end(), Magick::depthImage(depth[0]));
if(density.size()){
for_each ( image->begin(), image->end(), Magick::resolutionUnitsImage(Magick::PixelsPerInchResolution));
for_each ( image->begin(), image->end(), Magick::densityImage(Point(density[0])));
}
if(comment.size())
for_each ( image->begin(), image->end(), Magick::commentImage(std::string(comment.at(0))));
Magick::Blob output;
writeImages( image->begin(), image->end(), &output );
Rcpp::RawVector res(output.length());
std::memcpy(res.begin(), output.data(), output.length());
return res;
}
SEXP hclustThetaMatrix(SEXP mpcrossRF_, SEXP preClusterResults_)
{
BEGIN_RCPP
Rcpp::List preClusterResults = preClusterResults_;
bool noDuplicates;
R_xlen_t preClusterMarkers = countPreClusterMarkers(preClusterResults_, noDuplicates);
if(!noDuplicates)
{
throw std::runtime_error("Duplicate marker indices in call to hclustThetaMatrix");
}
Rcpp::S4 mpcrossRF = mpcrossRF_;
Rcpp::S4 rf = mpcrossRF.slot("rf");
Rcpp::S4 theta = rf.slot("theta");
Rcpp::RawVector data = theta.slot("data");
Rcpp::NumericVector levels = theta.slot("levels");
Rcpp::CharacterVector markers = theta.slot("markers");
if(markers.size() != preClusterMarkers)
{
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();
//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;
R_xlen_t 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);
Rbyte thetaDataValue = data((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
if(thetaDataValue != 0xFF)
{
total += levels(thetaDataValue);
counter++;
}
}
}
if(counter == 0) total = 0.5;
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) = total;
}
}
return result;
END_RCPP
}
static Rcpp::NumericMatrix x_tilde(Rcpp::NumericMatrix X,
Rcpp::IntegerVector nk,
Rcpp::IntegerMatrix groups,
Rcpp::NumericVector d_cur,
Rcpp::NumericMatrix eta_cur)
{
int K = nk.size();
int n_tot = X.nrow();
int p = X.ncol();
int L = groups.ncol();
Rcpp::NumericMatrix result(n_tot, p * K);
int idx = 0;
for (int k = 0; k < K; k++) {
int n = nk[k];
for (int j = 0; j < p; j++) {
//calculate sum for column j
double sum = 0.0;
for (int l = 0; l < L; l++) {
if (elem(groups, j, l)) {
sum += d_cur[l] * elem(eta_cur, l, k);
}
}
//multiply column j in submatrix k of X with sum
for (int i = 0; i < n; i++) {
elem(result, idx + i, p * k + j) = elem(X, idx + i, j) * sum;
}
}
idx += n;
}
return result;
}
static void print(Rcpp::IntegerVector a)
{
for (int i = 0; i < a.size(); i++) {
printf("%d ", a[i]);
}
putchar('\n');
}
static double bic_logistic(Rcpp::NumericMatrix X,
Rcpp::NumericVector y,
Rcpp::NumericMatrix beta_new,
double eps,
Rcpp::IntegerVector nk)
{
int n_tot = X.nrow();
int p = X.ncol();
int K = nk.size();
int idx = 0;
double ll = 0.0;
for (int k = 0; k < K; k++) {
int n = nk[k];
for (int i = 0; i < n; i++) {
double lp = 0.0;
for (int j = 0; j < p; j++) {
lp += elem(X, idx+i, j) * elem(beta_new, j, k);
}
ll += y[idx+i] * lp - log(1.0 + exp(lp));
}
idx += n;
}
double bic = -2.0 * ll + df(beta_new, eps) * log(n_tot);
return bic;
}
static double bic_linear(Rcpp::NumericMatrix X,
Rcpp::NumericVector y,
Rcpp::NumericMatrix beta_new,
double eps,
Rcpp::IntegerVector nk)
{
int n_tot = X.nrow();
int p = X.ncol();
int K = nk.size();
/*calculate SSe*/
double SSe = 0.0;
int idx = 0;
for (int k = 0; k < K; k++) {
int n = nk[k];
for (int i = 0; i < n; i++) {
double Xrow_betacol = 0.0;
for (int j = 0; j < p; j++) {
Xrow_betacol += elem(X, idx+i, j) * elem(beta_new, j, k);
}
SSe += pow(y[idx+i] - Xrow_betacol, 2);
}
idx += n;
}
double ll = -n_tot / 2.0 * (log(SSe) - log(n_tot) + log(2.0 * M_PI) + 1);
double bic = -2 * ll + df(beta_new, eps) * log(n_tot);
return bic;
}
static Rcpp::NumericMatrix next_beta(Rcpp::IntegerVector nk,
Rcpp::IntegerMatrix groups,
Rcpp::NumericMatrix alpha_new,
Rcpp::NumericVector d_new,
Rcpp::NumericMatrix eta_new)
{
int K = nk.size();
int p = groups.nrow();
int L = groups.ncol();
Rcpp::NumericMatrix result(p, K);
for (int k = 0; k < K; k++) {
for (int j = 0; j < p; j++) {
double sum = 0.0;
for (int l = 0; l < L; l++) {
if (elem(groups, j, l)) {
sum += d_new[l] * elem(eta_new, l, k);
}
}
elem(result, j, k) = elem(alpha_new, j, k) * sum;
}
}
return result;
}
// Calculate CPO for spatial Copula Cox PH
arma::vec LinvSpCopulaCox(Rcpp::NumericVector tobs, Rcpp::IntegerVector delta, Rcpp::NumericVector Xbeta,
Rcpp::NumericVector h, Rcpp::NumericVector d, arma::mat Cinv, arma::vec z){
int n = delta.size();
arma::vec res(n);
for(int i=0; i<n; ++i){
double Cii = Cinv(i,i);
double s2i = 1.0/Cii;
double mui = -s2i*( arma::dot(Cinv.col(i), z) - Cii*z[i] );
double si = std::sqrt(s2i);
double Fi = Foft(tobs[i], h, d, Xbeta[i]);
double PinvFyi = Rf_qnorm5(Fi, 0, 1, true, false);
double newzi = (PinvFyi-mui)/si;
if(delta[i]==0){
double St = 1.0-Rf_pnorm5(newzi, 0, 1, true, false);
//Rprintf( "St=%f\n", St );
res(i) = 1.0/St;
} else {
double fi = foft(tobs[i], h, d, Xbeta[i]);
double diff = -0.5*std::pow(newzi, 2) + 0.5*std::pow(PinvFyi, 2);
double ft = (1.0/si*std::exp(diff)*fi);
res(i) = 1.0/ft;
//Rprintf( "ft=%f\n", ft );
}
}
return(res);
}
static Rcpp::NumericMatrix x_tilde_2(Rcpp::NumericMatrix X,
Rcpp::IntegerVector nk,
Rcpp::IntegerMatrix groups,
Rcpp::NumericMatrix alpha_new,
Rcpp::NumericMatrix eta_cur)
{
int K = nk.size();
int n_tot = X.nrow();
int p = X.ncol();
int L = groups.ncol();
Rcpp::NumericMatrix result(n_tot, L);
for (int l = 0; l < L; l++) {
int k = -1;
int n = 0;
for (int i = 0; i < n_tot; i++) {
if (i == n){
k +=1;
n += nk[k];
}
double sum = 0.0;
for (int j = 0; j < p; j++) {
if (elem(groups, j, l)) {
sum += elem(X, i, j) * elem(alpha_new, j, k);
}
}
elem(result, i, l) = elem(eta_cur, l, k) * sum;
}
}
return result;
}
//' Update eigen values, vectors, and inverse matrices for irms
//'
//' @param tpm_prods array of transition probability matrix products
//' @param tpms array of transition probability matrices
//' @param pop_mat population level bookkeeping matrix
//' @param obstimes vector of observation times
//'
//' @return Updated eigenvalues, eigenvectors, and inverse matrices
// [[Rcpp::export]]
void tpmProdSeqs(Rcpp::NumericVector& tpm_prods, Rcpp::NumericVector& tpms, const Rcpp::IntegerVector obs_time_inds) {
// Get indices
int n_obs = obs_time_inds.size();
Rcpp::IntegerVector tpmDims = tpms.attr("dim");
// Ensure obs_time_inds starts at 0
Rcpp::IntegerVector obs_inds = obs_time_inds - 1;
// Set array pointers
arma::cube prod_arr(tpm_prods.begin(), tpmDims[0], tpmDims[1], tpmDims[2], false);
arma::cube tpm_arr(tpms.begin(), tpmDims[0], tpmDims[1], tpmDims[2], false);
// Generate tpm products and store them in the appropriate spots in the tpm product array
for(int j = 0; j < (n_obs - 1); ++j) {
prod_arr.slice(obs_inds[j+1] - 1) = tpm_arr.slice(obs_inds[j+1] - 1);
for(int k = (obs_inds[j+1] - 2); k > (obs_inds[j] - 1); --k) {
prod_arr.slice(k) = tpm_arr.slice(k) * prod_arr.slice(k + 1);
}
}
}
static Rcpp::NumericMatrix x_tilde_3(Rcpp::NumericMatrix X,
Rcpp::IntegerVector nk,
Rcpp::IntegerMatrix groups,
Rcpp::NumericMatrix alpha_new,
Rcpp::NumericVector d_new)
{
int K = nk.size();
int n_tot = X.nrow();
int p = X.ncol();
int L = groups.ncol();
Rcpp::NumericMatrix result(n_tot, L * K);
int idx = 0;
for (int k = 0; k < K; k++) {
int n = nk[k];
for (int l = 0; l < L; l++) {
for (int i = 0; i < n; i++) {
double sum = 0.0;
for (int j = 0; j < p; j++) {
if (elem(groups, j, l)) {
sum += elem(X, idx + i, j) * elem(alpha_new, j, k);
}
}
elem(result, idx + i, L * k + l) = d_new[l] * sum;
}
}
idx += n;
}
return result;
}
void check_topset(const Rcpp::IntegerVector& top) {
for (size_t t=1; t<top.size(); ++t) {
if (top[t] < top[t-1]) {
throw std::runtime_error("numbers of top genes must be sorted");
}
}
return;
}
//[[Rcpp::export]]
Rcpp::CharacterVector edgeIdCpp (Rcpp::IntegerMatrix edge, std::string type) {
Rcpp::IntegerVector ances = getAnces(edge);
Rcpp::IntegerVector desc = getDesc(edge);
int nedge;
if (type == "tip" || type == "internal") {
Rcpp::IntegerVector tips = tipsFast(ances);
nedge = tips.size();
Rcpp::IntegerVector ans = match(tips, desc);
if (type == "tip") {
Rcpp::IntegerVector tmpAnces(nedge);
Rcpp::IntegerVector tmpDesc(nedge);
for (int j = 0; j < nedge; j++) {
tmpAnces[j] = ances[ans[j]-1];
tmpDesc[j] = desc[ans[j]-1];
}
Rcpp::CharacterVector c1(nedge);
c1 = edgeIdCppInternal(tmpAnces, tmpDesc);
return c1;
}
else if (type == "internal") {
int allEdges = ances.size();
Rcpp::IntegerVector idEdge = Rcpp::seq_len(allEdges);
Rcpp::IntegerVector intnd = Rcpp::setdiff(idEdge, ans);
nedge = intnd.size();
Rcpp::IntegerVector tmpAnces(nedge);
Rcpp::IntegerVector tmpDesc(nedge);
for (int j = 0; j < nedge; j++) {
tmpAnces[j] = ances[intnd[j]-1];
tmpDesc[j] = desc[intnd[j]-1];
}
Rcpp::CharacterVector c1(nedge);
c1 = edgeIdCppInternal(tmpAnces, tmpDesc);
return c1;
}
}
else {
nedge = ances.size();
Rcpp::IntegerVector tmpAnces = ances;
Rcpp::IntegerVector tmpDesc = desc;
Rcpp::CharacterVector c1(nedge);
c1 = edgeIdCppInternal(tmpAnces, tmpDesc);
return c1;
}
return "";
}
// Calculate mk = sum_i I(M(ti)=k), 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 Getmk(Rcpp::IntegerVector& mk, const Rcpp::IntegerVector& Mt){
int n = Mt.size();
std::fill(mk.begin(), mk.end(), 0);
for (int i=0; i<n; ++i){
int k = Mt[i];
mk[k] +=1;
}
}
Rcpp::IntegerVector match_and_substract(Rcpp::IntegerVector x, Rcpp::IntegerVector yInt) {
int y(1);
y = yInt[0];
for (unsigned k=0; k < x.size(); ++k) {
if (x[k] > y)
x[k] = x[k] - 1;
}
return x;
}
// 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]);
}
}
}
void fill(Rcpp::IntegerVector idx, SEXP A){
viennacl::vector_range<viennacl::vector_base<T> > v_sub(*shptr.get(), r);
#ifdef UNDEF
Eigen::Matrix<T, Eigen::Dynamic, 1> Am;
Am = Rcpp::as<Eigen::Matrix<T, Eigen::Dynamic, 1> >(A);
for(int i = 0; i < idx.size(); i++) {
v_sub(idx[i]) = Am(i);
}
#endif
}
std::vector<int> tabulate_tips (Rcpp::IntegerVector ances) {
// tabulates ancestor nodes that are not the root.
int n = Rcpp::max(ances);
std::vector<int> ans(n);
for (int i=0; i < ances.size(); i++) {
int j = ances[i];
if (j > 0) {
ans[j - 1]++;
}
}
return ans;
}
bool intercrossingGenerations(Rcpp::DataFrame& pedigree, int nFounders, Rcpp::IntegerVector& mpcrossID, std::vector<int>& output)
{
#define pedFind(id) findIDInPedigree(id, pedigree)
int nFinals = mpcrossID.size();
int nPedigreeRows = pedigree.nrows();
Rcpp::IntegerVector male = Rcpp::as<Rcpp::IntegerVector>(pedigree("Male")), female = Rcpp::as<Rcpp::IntegerVector>(pedigree("Female"));
for(int finalCounter = 0; finalCounter < nFinals; finalCounter++)
{
int currentPedRow = pedFind(mpcrossID[finalCounter]);
if(currentPedRow < 0 || currentPedRow > nPedigreeRows) return false;
//Counter to stop if the loop goes too long and might be infinite
int loopCounter = 0;
//Pick the last row and proceed backwards up the pedigree until we're through all the selfing generations
while(male(currentPedRow) == female(currentPedRow))
{
int nextPedID = male(currentPedRow);
if(nextPedID < 0 || nextPedID > nPedigreeRows) return false;
currentPedRow = pedFind(nextPedID);
if(currentPedRow < 0 || currentPedRow > nPedigreeRows) return false;
loopCounter++;
if(loopCounter > 2000) return false;
}
//When we reach an NA in the pedigree the while condition will terminate, which is an error
if((male(currentPedRow) != male(currentPedRow)) || (female(currentPedRow) != female(currentPedRow)))
{
return false;
}
int ngen = 0;
while(male(currentPedRow) > 0)
{
int nextPedID = male(currentPedRow);
if(nextPedID < 0 || nextPedID > nPedigreeRows) return false;
currentPedRow = pedFind(nextPedID);
if(currentPedRow < 0 || currentPedRow > nPedigreeRows) return false;
ngen++;
if(ngen > 2000) return false;
}
//another check for NA values
if(male(currentPedRow) != male(currentPedRow))
{
return false;
}
output[finalCounter] = ngen - (int)((log(nFounders) / log(2)) + 0.5);
if(output[finalCounter] < 0) return false;
}
#undef pedFind
return true;
}
// [[Rcpp::export]]
Rcpp::IntegerVector tabulate_cpp(const Rcpp::IntegerVector & v, R_xlen_t nlevels) {
// Using R_xlen_t to avoid checking for entries < 0
std::vector<R_xlen_t> table(nlevels);
R_xlen_t n = v.size();
for (R_xlen_t i = 0; i < n; ++i) {
table.at( v.at(i) - 1 ) ++;
}
// Wrapp may throw errors with R_xlen_t
// return wrap(table);
IntegerVector a(table.size());
std::copy(table.begin(), table.end(), a.begin());
return a;
}
//////////////////////////////////////////////////////////////////////
// Independent Cox PH
/////////////////////////////////////////////////////////////////////
// Calculate CPO for Independent Cox PH
arma::vec LinvIndeptCox(Rcpp::NumericVector tobs, Rcpp::IntegerVector delta, Rcpp::NumericVector Xbeta,
Rcpp::NumericVector h, Rcpp::NumericVector d){
int n = delta.size();
arma::vec res(n);
for(int i=0; i<n; ++i){
if(delta[i]==0){
res[i] = 1.0/(1.0-Foft(tobs[i], h, d, Xbeta[i]));
}else{
res[i] = 1.0/foft(tobs[i], h, d, Xbeta[i]);
}
}
return(res);
}
void ribi::ctm::Helper::CalcMaxLikelihood(
const std::string& newick,
Rate& birth_rate,
Rate& death_rate,
const Part part
) const
{
assert(!newick.empty());
auto& r = ribi::Rinside().Get();
r.parseEval("library(ape)");
r.parseEval("library(DDD)");
r["newick"] = newick;
r.parseEval("phylogeny <- read.tree(text = newick)");
r.parseEval("branch_lengths <- phylogeny$edge.length");
switch (part)
{
case Part::branch_lengths: r["part"] = 0; break;
case Part::phylogeny : r["part"] = 1; break;
}
r.parseEval(
"max_likelihood <- bd_ML("
" brts = branch_lengths,"
" cond = 1," // # cond == 1 : conditioning on stem or crown age and non-extinction of the phylogeny
" btorph = part"
")"
);
r.parseEval("lambda0 <- max_likelihood$lambda0");
r.parseEval("mu0 <- max_likelihood$mu0");
r.parseEval("conv <- max_likelihood$conv");
const Rcpp::DoubleVector lambda0 = r["lambda0"];
const Rcpp::DoubleVector mu0 = r["mu0"];
const Rcpp::IntegerVector conv = r["conv"];
assert(lambda0.size() == 1);
assert(mu0.size() == 1);
assert(conv.size() == 1);
const bool has_converged = conv[0] == 0;
if (!has_converged)
{
std::stringstream s;
s << __func__ << ": has not converged" ;
throw std::runtime_error(s.str());
}
birth_rate = lambda0[0] / boost::units::si::second;
death_rate = mu0[0] / boost::units::si::second;
}
SEXP rawSymmetricMatrixSubsetObject(SEXP object_, SEXP indices_)
{
BEGIN_RCPP
Rcpp::S4 object = object_;
Rcpp::RawVector oldData = object.slot("data");
Rcpp::IntegerVector indices = indices_;
R_xlen_t newNMarkers = indices.size();
Rcpp::RawVector newData((indices.size() * (indices.size() + (R_xlen_t)1))/(R_xlen_t)2);
R_xlen_t counter = 0;
//Column
for(R_xlen_t j = 0; j < newNMarkers; j++)
{
//Row
for(R_xlen_t i = 0; i <= j; i++)
{
R_xlen_t indexJ = indices[j], indexI = indices[i];
if(indexI > indexJ) std::swap(indexI, indexJ);
newData(counter) = oldData[(indexJ*(indexJ-(R_xlen_t)1))/(R_xlen_t)2 + indexI - (R_xlen_t)1];
counter++;
}
}
return newData;
END_RCPP
}
Permutation::Permutation(Rcpp::IntegerVector &vv)
: d_perm(vv),
n(vv.size()) {
int *vpt = vv.begin();
std::vector<bool> chk(n);
std::fill(chk.begin(), chk.end(), false);
for (int i = 0; i < n; i++) {
int vi = vpt[i];
if (vi < 0 || n <= vi)
throw runtime_error("permutation elements must be in [0,n)");
if (chk[vi])
throw runtime_error("permutation is not a permutation");
chk[vi] = true;
}
}
//[[Rcpp::export]]
Rcpp::IntegerVector tipsSafe (Rcpp::IntegerVector ances, Rcpp::IntegerVector desc) {
Rcpp::IntegerVector res = Rcpp::match(desc, ances);
Rcpp::LogicalVector istip = Rcpp::is_na(res);
int nedge = ances.size();
std::vector<int> y(nedge);
int j = 0;
for(int i = 0; i < nedge; i++) {
if (istip[i]) {
y[j] = desc[i];
j++;
}
}
Rcpp::IntegerVector ans(j);
std::copy (y.begin(), y.begin()+j, ans.begin());
std::sort (ans.begin(), ans.end());
return ans;
}
Rcpp::CharacterVector edgeIdCppInternal (Rcpp::IntegerVector tmp1, Rcpp::IntegerVector tmp2) {
Rcpp::CharacterVector tmpV1 = Rcpp::as< Rcpp::CharacterVector >(tmp1);
Rcpp::CharacterVector tmpV2 = Rcpp::as< Rcpp::CharacterVector >(tmp2);
int Ne = tmp1.size();
Rcpp::CharacterVector res(Ne);
for (int i = 0; i < Ne; i++) {
std::string tmpS1;
tmpS1 = tmpV1[i];
std::string tmpS2;
tmpS2 = tmpV2[i];
std::string tmpS;
tmpS = tmpS1.append("-");
tmpS = tmpS.append(tmpS2);
res[i] = tmpS;
}
return res;
}
// [[Rcpp::export]]
XPtrImage magick_image_readbin(Rcpp::RawVector x, Rcpp::CharacterVector density, Rcpp::IntegerVector depth, bool strip = false){
XPtrImage image = create();
#if MagickLibVersion >= 0x689
Magick::ReadOptions opts = Magick::ReadOptions();
#if MagickLibVersion >= 0x690
opts.quiet(1);
#endif
if(density.size())
opts.density(std::string(density.at(0)).c_str());
if(depth.size())
opts.depth(depth.at(0));
Magick::readImages(image.get(), Magick::Blob(x.begin(), x.length()), opts);
#else
Magick::readImages(image.get(), Magick::Blob(x.begin(), x.length()));
#endif
if(strip)
for_each (image->begin(), image->end(), Magick::stripImage());
return image;
}
SEXP constructDissimilarityMatrixInternal(unsigned char* data, std::vector<double>& levels, int size, SEXP clusters_, int start, const std::vector<int>& currentPermutation)
{
Rcpp::IntegerVector clusters = Rcpp::as<Rcpp::IntegerVector>(clusters_);
int minCluster = *std::min_element(clusters.begin(), clusters.end()), maxCluster = *std::max_element(clusters.begin(), clusters.end());
if(minCluster != 1)
{
throw std::runtime_error("Clusters must have consecutive indices starting at 1");
}
std::vector<std::vector<int> > groupIndices(maxCluster);
for(int i = 0; i < clusters.size(); i++)
{
groupIndices[clusters[i]-1].push_back(currentPermutation[i + start]);
}
std::vector<int> table(levels.size());
Rcpp::NumericMatrix result(maxCluster, maxCluster);
for(int rowCluster = 1; rowCluster <= maxCluster; rowCluster++)
{
for(int columnCluster = 1; columnCluster <= rowCluster; columnCluster++)
{
const std::vector<int>& columnIndices = groupIndices[columnCluster-1];
const std::vector<int>& rowIndices = groupIndices[rowCluster-1];
std::fill(table.begin(), table.end(), 0);
for(std::vector<int>::const_iterator columnMarker = columnIndices.begin(); columnMarker != columnIndices.end(); columnMarker++)
{
for(std::vector<int>::const_iterator rowMarker = rowIndices.begin(); rowMarker != rowIndices.end(); rowMarker++)
{
int x = *rowMarker, y = *columnMarker;
if(x < y) std::swap(x, y);
int byte = data[x *(x + (R_xlen_t)1)/(R_xlen_t)2 + y];
if(byte == 255) throw std::runtime_error("Values of NA not allowed");
table[byte]++;
}
}
double sum = 0;
for(int i = 0; i < table.size(); i++) sum += table[i] * levels[i];
result(rowCluster-1, columnCluster-1) = result(columnCluster-1, rowCluster-1) = sum / (columnIndices.size() * rowIndices.size());
}
}
return result;
}
SEXP top_cumprop_internal(Rcpp::RObject incoming, Rcpp::IntegerVector topset) {
auto mat=beachmat::create_matrix<M>(incoming);
const size_t ncells=mat->get_ncol();
const size_t ngenes=mat->get_nrow();
check_topset(topset);
Rcpp::NumericMatrix percentages(topset.size(), ncells);
typename M::vector holder(ngenes);
for (size_t c=0; c<ncells; ++c) {
mat->get_col(c, holder.begin()); // need to copy as cumsum will change ordering.
double totals=std::accumulate(holder.begin(), holder.end(), static_cast<typename M::type>(0));
auto cur_col=percentages.column(c);
compute_cumsum<typename M::type, typename M::vector>(holder.begin(), ngenes, topset, cur_col.begin());
for (auto& p : cur_col) { p/=totals; }
}
return percentages;
}
