// [[Rcpp::export]]
NumericVector CPP_row_norms_sparse(int nr, int nc, IntegerVector p, IntegerVector row_of, NumericVector x, int norm_code, double p_norm = 2.0) {
check_norm(norm_code, p_norm);
NumericVector norms(nr, 0.0);
NumericVector::iterator _x = x.begin();
IntegerVector::iterator _p = p.begin();
IntegerVector::iterator _row_of = row_of.begin();
NumericVector::iterator _norms = norms.begin();
for (int col = 0; col < nc; col++) {
for (int i = _p[col]; i < _p[col+1]; i++) {
int row = _row_of[i];
if (norm_code == 0) _norms[row] += _x[i] * _x[i];
else if (norm_code == 1) { if (fabs(_x[i]) > _norms[row]) _norms[row] = fabs(_x[i]); }
else if (norm_code == 2) _norms[row] += fabs(_x[i]);
else if (norm_code == 3) {
if (p_norm > 0)
_norms[row] += pow(fabs(_x[i]), p_norm);
else
_norms[row] += (_x[i] != 0);
}
}
}
if (norm_code == 0) norms = sqrt(norms);
else if (norm_code == 3 && p_norm > 1.0) norms = pow(norms, 1.0 / p_norm);
/* no adjustment needed for Maximum and Manhattan norms */
return norms;
}
// [[Rcpp::export]]
NumericVector CPP_dsm_score_sparse(int nr, int nc, IntegerVector p, IntegerVector row_of, NumericVector f, NumericVector f1, NumericVector f2, double N, int am_code, int sparse, int transform_code) {
if (am_code < 0 || am_code >= am_table_entries)
stop("internal error -- invalid AM code");
am_func AM = am_table[am_code]; /* selected association measure */
// -- don't check whether sparse=TRUE, so power users can compute non-sparse AMs for nonzero entries of the sparse matrix
// if (!sparse) stop("only sparse association scores can be used with sparse matrix representation");
int n_items = f.size();
NumericVector scores(n_items);
if (am_code != 0 && (nr != f1.size() || nc != f2.size()))
stop("internal error -- marginal vectors f1 and f2 not conformable with matrix f");
IntegerVector::iterator _p = p.begin();
IntegerVector::iterator _row_of = row_of.begin();
NumericVector::iterator _f = f.begin();
NumericVector::iterator _f1 = f1.begin();
NumericVector::iterator _f2 = f2.begin();
NumericVector::iterator _scores = scores.begin();
for (int col = 0; col < nc; col++) {
for (int i = _p[col]; i < _p[col+1]; i++) {
/* frequeny measure (*am_code == 0) is a special case, since marginals may not be available ("reweight" mode) */
double score = (am_code == 0) ? _f[i] : AM(_f[i], _f1[_row_of[i]], _f2[col], N, sparse);
_scores[i] = (transform_code) ? transform(score, transform_code) : score;
}
}
return scores;
}
// [[Rcpp::export]]
List runit_lang_binarycall(IntegerVector x1, IntegerVector x2 ){
Language call( "seq", Named("from", 10 ), Named("to", 0 ) ) ;
List output( x1.size() ) ;
std::transform(
x1.begin(), x1.end(), x2.begin(),
output.begin(),
binary_call<int,int>(call)
) ;
return output ;
}
// [[Rcpp::export]]
List integer_erase_range_2( IntegerVector x, IntegerVector y ){
IntegerVector::iterator it = x.begin()+1 ;
while( it != x.end() ){
it = x.erase(it) ;
}
it = y.begin() + 1 ;
while( it != y.end() ){
it = y.erase(it) ;
}
return List::create( x, y ) ;
}
// [[Rcpp::export(".LRmix")]]
NumericVector LRmix(IntegerVector ProfVic, IntegerVector ProfSus, List listFreqs){
int i;
int nLoci = listFreqs.size();
NumericVector LocusLRs(nLoci);
for(i = 0; i < nLoci; i++){
NumericVector Freqs = as<NumericVector>(listFreqs[i]);
LocusLRs[i] = locusLRmix(ProfVic.begin() + 2 * i, ProfSus.begin() + 2 * i, Freqs);
}
return LocusLRs;
}
inline STORAGE process_chunk(const SlicingIndex& indices) {
int n = indices.size();
if (n == 0 || idx > n || idx < -n) return def;
int i = idx > 0 ? (idx -1) : (n+idx);
typedef VectorSliceVisitor<ORDER_RTYPE> Slice;
typedef OrderVectorVisitorImpl<ORDER_RTYPE,true,Slice> Visitor;
typedef Compare_Single_OrderVisitor<Visitor> Comparer;
Comparer comparer(Visitor(Slice(order, indices)));
IntegerVector sequence = seq(0,n-1);
std::nth_element(sequence.begin(), sequence.begin() + i, sequence.end(), comparer);
return data[ indices[ sequence[i] ] ];
}
void single_session(IntegerVector timestamps, IntegerVector& delta_output,
int& ts_iter_count, int& threshold, std::deque <int>& hash_reps){
int delta_holding;
int hash_rep_holding = 1;
delta_output[ts_iter_count] = NA_INTEGER;
if(timestamps.size() >= 2) {
std::sort(timestamps.begin(), timestamps.end());
for(unsigned int i = 1; i < timestamps.size(); i++){
ts_iter_count++;
delta_holding = (timestamps[i] - timestamps[i-1]);
if(delta_holding >= threshold){
delta_output[ts_iter_count] = NA_INTEGER;
hash_reps.push_back(hash_rep_holding);
hash_rep_holding = 1;
} else {
if(timestamps[i] == NA_INTEGER || timestamps[i-1] == NA_INTEGER){
delta_output[ts_iter_count] = NA_INTEGER;
} else {
delta_output[ts_iter_count] = delta_holding;
}
hash_rep_holding++;
}
}
}
hash_reps.push_back(hash_rep_holding);
ts_iter_count++;
}
// [[Rcpp::export]]
SEXP next_combinations_replace(Environment I, unsigned long d) {
IntegerVector x = I["index"];
unsigned int n = I["unique_n"];
unsigned int r = x.size();
IntegerVector status = I["status"];
unsigned int i,j;
unsigned int* xptr = (unsigned int *) x.begin();
if (as<int>(I["status"]) == 0) {
if (!MBnext_multicombination(xptr, n, r)) {
return R_NilValue;
}
} else {
I["status"] = 0;
}
if (d>1) {
IntegerMatrix P(d,r);
P(0,_) = x+1;
for(i=1; i<d; i++) {
if(!MBnext_multicombination(xptr, n, r)) {
I["status"] = i;
break;
}
P(i,_) = x+1;
}
return P;
} else {
IntegerVector y(r);
for(j=0; j<r; j++) y[j] = xptr[j]+1;
return y;
}
}
//' @title Mode
//' @description
//' \code{mode} returns the most frequent value of an integer vector
//'
//' @param x - An integer vector
//'
//' @examples
//' mode(c(1,2,2))
//'
//' @return Most frequent value of \code{x}
//'
//' @export
// [[Rcpp::export]]
int mode(IntegerVector x) {
if(x.size()==0)
return NA_INTEGER;
IntegerVector y = clone(x);
std::sort(y.begin(),y.end());
int maxCount=1, mode=y[0], count=1;
for(int i=1;i<y.size();i++){
if(y[i]==y[i-1])
count++;
else
{
if(count>maxCount)
{
maxCount=count;
mode=y[i-1];
}
count=1;
}
}
if(count>maxCount)
mode=y[y.size()-1];
return mode;
}
// [[Rcpp::export]]
S4 CPP_scale_margins_sparse(S4 M, NumericVector rows, NumericVector cols, bool duplicate = true) {
if (!M.is("dgCMatrix"))
stop("internal error -- not a canonical sparse matrix");
IntegerVector dims = M.slot("Dim");
int nr = dims[0], nc = dims[1];
if (nr != rows.size() || nc != cols.size())
stop("internal error -- row/column weights not conformable with matrix");
if (duplicate)
M = clone(M);
IntegerVector p = M.slot("p");
IntegerVector::iterator _p = p.begin();
IntegerVector row_of = M.slot("i");
IntegerVector::iterator _row_of = row_of.begin();
NumericVector x = M.slot("x");
NumericVector::iterator _x = x.begin();
NumericVector::iterator _rows = rows.begin();
for (int col = 0; col < nc; col++) {
double col_weight = cols[col];
for (int i = _p[col]; i < _p[col+1]; i++) {
_x[i] *= _rows[_row_of[i]] * col_weight;
}
}
return M;
}
// [[Rcpp::export]]
NumericVector CPP_col_norms_sparse(int nr, int nc, IntegerVector p, IntegerVector row_of, NumericVector x, int norm_code, double p_norm = 2.0) {
check_norm(norm_code, p_norm);
NumericVector norms(nc, 0.0);
NumericVector::iterator _x = x.begin();
IntegerVector::iterator _p = p.begin();
// IntegerVector::iterator _row_of = row_of.begin();
NumericVector::iterator _norms = norms.begin();
for (int col = 0; col < nc; col++) {
double accum = 0.0;
for (int i = _p[col]; i < _p[col+1]; i++) {
if (norm_code == 0) accum += _x[i] * _x[i];
else if (norm_code == 1) { if (fabs(_x[i]) > accum) accum = fabs(_x[i]); }
else if (norm_code == 2) accum += fabs(_x[i]);
else if (norm_code == 3) {
if (p_norm > 0)
accum += pow(fabs(_x[i]), p_norm);
else
accum += (_x[i] != 0);
}
}
if (norm_code == 0) _norms[col] = sqrt(accum);
else if (norm_code == 3 && p_norm > 1.0) _norms[col] = pow(accum, 1.0 / p_norm);
else /* other norms */ _norms[col] = accum;
}
return norms;
}
// **********************************************************//
// 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;
}
NumericVector logLikMixHMM(NumericVector transitionMatrix, NumericVector emissionArray,
NumericVector initialProbs, IntegerVector obsArray, NumericMatrix coefs,
NumericMatrix X_, IntegerVector numberOfStates) {
IntegerVector eDims = emissionArray.attr("dim"); //m,p,r
IntegerVector oDims = obsArray.attr("dim"); //k,n,r
int q = coefs.nrow();
arma::mat coef(coefs.begin(),q,coefs.ncol());
coef.col(0).zeros();
arma::mat X(X_.begin(),oDims[0],q);
arma::mat lweights = exp(X*coef).t();
if(!lweights.is_finite()){
return wrap(-std::numeric_limits<double>::max());
}
lweights.each_row() /= sum(lweights,0);
arma::colvec init(initialProbs.begin(),eDims[0], true);
arma::mat transition(transitionMatrix.begin(),eDims[0],eDims[0], true);
arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], true);
arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false);
arma::vec alpha(eDims[0]);
NumericVector ll(oDims[0]);
double tmp;
arma::vec initk(eDims[0]);
for(int k = 0; k < oDims[0]; k++){
initk = init % reparma(lweights.col(k),numberOfStates);
for(int i=0; i < eDims[0]; i++){
alpha(i) = initk(i);
for(int r = 0; r < oDims[2]; r++){
alpha(i) *= emission(i,obs(k,0,r),r);
}
}
tmp = sum(alpha);
ll(k) = log(tmp);
alpha /= tmp;
arma::vec alphatmp(eDims[0]);
for(int t = 1; t < oDims[1]; t++){
for(int i = 0; i < eDims[0]; i++){
alphatmp(i) = arma::dot(transition.col(i), alpha);
for(int r = 0; r < oDims[2]; r++){
alphatmp(i) *= emission(i,obs(k,t,r),r);
}
}
tmp = sum(alphatmp);
ll(k) += log(tmp);
alpha = alphatmp/tmp;
}
}
return ll;
}
// [[Rcpp::export]]
const bool test3(IntegerVector ipd, int ipd_) {
//int max_ipd = max(ipd);
if (std::find(ipd.begin(), ipd.end(), ipd_) != ipd.end()) {
return true;
} else {
return false;
}
}
// [[Rcpp::export]]
std::tr1::unordered_set<int> unique1(IntegerVector x) {
std::tr1::unordered_set<int> seen;
for(IntegerVector::iterator it = x.begin(); it != x.end(); ++it) {
seen.insert(*it);
}
return seen;
}
RCPP_FUNCTION_2(List, lme4_PermChk, IntegerVector perm, IntegerVector x) {
IntegerVector zerob = clone(perm); // modifiable copy
int bb = *(std::min_element(zerob.begin(), zerob.end()));
if (bb != 0) zerob = zerob - bb;
MatrixNs::Permutation pp(zerob);
return List::create(_["forw"] = pp.forward(x),
_["inv"] = pp.inverse(x));
}
// **********************************************************//
// Calculate mu matrix for entire document //
// **********************************************************//
// [[Rcpp::export]]
NumericMatrix mu_mat(NumericMatrix p_d, List xi, IntegerVector edgetrim) {
NumericMatrix sample = xi[max(edgetrim)-1];
NumericMatrix mumat(xi.size(), sample.nrow());
for (IntegerVector::iterator it = edgetrim.begin(); it != edgetrim.end(); ++it) {
int it2 = *it-1;
mumat(it2, _) = mu_vec(p_d(it2, _), xi[it2]);
}
return mumat;
}
int mode(IntegerVector x) {
int n=unique(x).size();
NumericVector y(n);
for (int i=0; i<n; ++i)
y[i]=std::count(x.begin(),x.end(),unique(x)[i]);
int m=max(y);
int q=std::distance(y.begin(),std::find(y.begin(),y.end(),m));
return unique(x)[q];
}
// **********************************************************//
// Likelihood evaluation of Timepart //
// **********************************************************//
// [[Rcpp::export]]
double Timepartsum(NumericMatrix mumat, double sigma_tau, IntegerVector senders, NumericVector timeinc, IntegerVector edgetrim){
double timesum = 0;
for (IntegerVector::iterator it = edgetrim.begin(); it != edgetrim.end(); ++it) {
int it2 = *it-1;
double a_d = senders[it2];
timesum += Timepart(mumat(it2,_), sigma_tau, a_d, timeinc[it2]);
}
return timesum;
}
// [[Rcpp::export]]
const bool test2(IntegerVector ipd, int ipd_) {
//int max_ipd = max(ipd);
std::set<int> ipd_set(ipd.begin(), ipd.end());
if (ipd_set.find(ipd_) != ipd_set.end()) {
return true;
} else {
return false;
}
}
// [[Rcpp::export]]
List runit_lang_unarycallindex(IntegerVector x){
Language call( "seq", 10, 0 ) ;
List output( x.size() ) ;
std::transform(
x.begin(), x.end(),
output.begin(),
unary_call<int>(call,2)
) ;
return output ;
}
// [[Rcpp::export]]
List runit_lang_unarycall(IntegerVector x){
Language call( "seq", Named("from", 10 ), Named("to", 0 ) ) ;
List output( x.size() ) ;
std::transform(
x.begin(), x.end(),
output.begin(),
unary_call<int>(call)
) ;
return output ;
}
//parses the GR object.
void parseRegions(std::vector<GArray>& container, RObject& gr, samfile_t* in){
if (not gr.inherits("GRanges"))
stop("must provide a GRanges object");
IntegerVector starts = as<IntegerVector>(as<RObject>(gr.slot("ranges")).slot("start"));
IntegerVector lens = as<IntegerVector>(as<RObject>(gr.slot("ranges")).slot("width"));
RObject chrsRle = as<RObject>(gr.slot("seqnames"));
RObject strandsRle = as<RObject>(gr.slot("strand"));
RleIter chrs(chrsRle);
RleIter strands(strandsRle);
container.reserve(container.size() + starts.length());
Iint e_starts = starts.end(); Iint i_starts = starts.begin(); Iint i_lens = lens.begin();
int lastStrandRun = -1;
int strand = -1;
int lastChrsRun = -1;
int rid = -1;
for (; i_starts < e_starts; ++i_starts, ++i_lens, chrs.next(), strands.next()){
//if new run, update chromosome
if (lastChrsRun != chrs.run){
lastChrsRun = chrs.run;
rid = getRefId(in, chrs.getValue());
if (rid == -1)
stop("chromosome " + (std::string)chrs.getValue() + " not present in the bam file");
}
//if new run, update strand
if (lastStrandRun != strands.run){
lastStrandRun = strands.run;
const std::string& s = strands.getValue();
if (s == "-"){ strand = -1; }
else if (s == "+"){ strand = +1; }
else { strand = 0; }
}
container.push_back(GArray(rid, *i_starts - 1, *i_lens, strand));
}
}
//' @title Vertex coloring of a sparse undirected graph
//' @description Generate proper vertex coloring of a sparse undirected graph.
//' @param pntr,idx row pointers and column indices of the adjacency matrix, in compressed column-oriented format. Must use zero-based indexing.
//' @param nvars Number of vertices.
//' @return An integer vector of length nvars, where each element represents the color of the corresponding vertex. Indices are zero-based.
//' @details For internal use. You should not have to call this function directly.
//[[Rcpp::export]]
Rcpp::IntegerVector get_colors(const IntegerVector& pntr, //row/col pointer
const IntegerVector& idx, // col/row index
const int nvars) {
std::vector<std::set<int> > P(nvars);
std::vector<std::set<int> > forb(nvars);
Rcpp::IntegerVector colors(nvars);
std::set<int> used;
std::set<int> valid;
for (int m=0; m < nvars; m++) {
P[m] = S(idx.begin()+pntr(m), idx.begin()+pntr(m+1)); // rows
}
int max_color = 0;
used.insert(0);
for (int i=0; i<nvars; i++) {
if (forb[i].empty()) {
colors[i] = 0;
} else {
valid.clear();
set_difference(used.begin(), used.end(),
forb[i].begin(), forb[i].end(),
std::inserter(valid,valid.begin()));
if (valid.empty()) { // add new color
max_color++;
used.insert(max_color);
colors[i] = max_color;
} else {
colors[i] = *valid.begin();
}
}
for (auto j : P[i]) {
forb[j].insert(colors[i]);
}
}
return(Rcpp::wrap(colors));
}
//[[Rcpp::export(".locusIBS")]]
IntegerVector locusIBS(IntegerVector ProfMat, int N){
// assumes pnProfMat is a vector of length 4 * N
IntegerVector result(N);
int i;
for(i = 0; i < N; i++){
int i1 = 4 * i;
result[i] = profIBS(ProfMat.begin() + i1);
}
return result;
}
// get a set of permutations of a vector, as columns of a matrix
// [[Rcpp::export]]
IntegerMatrix permute_ivector(const int n_perm, const IntegerVector x)
{
unsigned int length = x.size();
IntegerMatrix result(length,n_perm);
for(unsigned int i=0; i<n_perm; i++) {
IntegerVector permx = permute_ivector(x);
std::copy(permx.begin(), permx.end(), result.begin()+i*length);
}
return result;
}
double prob(IntegerVector Prof, List listFreqs){
int nLoci = listFreqs.size();
int nLoc;
double dProd = 1;
for(nLoc = 0; nLoc < nLoci; nLoc++){
int i1 = 2*nLoc;
NumericVector Freq = as<NumericVector>(listFreqs[nLoc]);
dProd *= locusProb(Prof.begin() + i1, Freq);
}
return dProd;
}
List viterbi(NumericVector transitionMatrix, NumericVector emissionArray,
NumericVector initialProbs, IntegerVector obsArray) {
IntegerVector eDims = emissionArray.attr("dim"); //m,p,r
IntegerVector oDims = obsArray.attr("dim"); //k,n,r
arma::vec init(initialProbs.begin(), eDims[0], false);
arma::mat transition(transitionMatrix.begin(), eDims[0], eDims[0], false);
arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], false);
arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false);
arma::umat q(oDims[0], oDims[1]);
arma::vec logp(oDims[0]);
arma::mat delta(eDims[0],oDims[1]);
arma::umat phi(eDims[0],oDims[1]);
for(int k=0; k<oDims[0]; k++){
delta.col(0) = init;
for(int r=0; r<eDims[2]; r++){
delta.col(0) += emission.slice(r).col(obs(k,0,r));
}
phi.col(0).zeros();
for(int t=1; t<oDims[1]; t++){
for(int j=0; j<eDims[0]; j++){
(delta.col(t-1)+transition.col(j)).max(phi(j,t));
delta(j,t) = delta(phi(j,t),t-1)+transition(phi(j,t),j);
for(int r=0; r<eDims[2]; r++){
delta(j,t) += emission(j,obs(k,t,r),r);
}
}
}
delta.col(oDims[1]-1).max(q(k,oDims[1]-1));
for(int t=(oDims[1]-2); t>=0; t--){
q(k,t) = phi(q(k,t+1),t+1);
}
logp(k) = delta.col(oDims[1]-1).max();
}
return List::create(Named("q") = wrap(q),Named("logp") = wrap(logp));
}
// [[Rcpp::export]]
IntegerVector kMeansRcpp(const NumericMatrix data,
const int K,
IntegerVector init_labels) {
int N = data.nrow();
int p = data.ncol();
bool labels_not_convegent_yet = true;
ivec ref_labels(init_labels.begin(), init_labels.size(), false);
ivec cluster_labels = zeros<ivec>(N);
mat medoids = zeros<mat>(K, p);
mat data_all(data.begin(), N, p, false);
mat data_temp;
rowvec data_sbj;
rowvec mdd_vec;
// get the initial medoid
int cnt_wthn_clstr = 0;
int itr_clstrs = 0;
int itr_sbjs = 0;
double dstnc_ref = datum::inf;
double dstnc = 0.0;
while (labels_not_convegent_yet) {
for (itr_clstrs = 0; itr_clstrs < K; itr_clstrs++) {
data_temp = data_all.rows(find(ref_labels == itr_clstrs));
medoids.row(itr_clstrs) = mean(data_temp, 0);
}
for (itr_sbjs = 0; itr_sbjs < N; itr_sbjs++) {
data_sbj = data_all.row(itr_sbjs);
// std::cout << data_sbj << std::endl;
dstnc_ref = datum::inf;
for (itr_clstrs = 0; itr_clstrs < K; itr_clstrs++) {
mdd_vec = medoids.row(itr_clstrs);
dstnc = norm(data_sbj - mdd_vec, 2);
if (dstnc < dstnc_ref) {
dstnc_ref = dstnc;
cluster_labels(itr_sbjs) = itr_clstrs;
}
}
}
if (cluster_labels == ref_labels) {
labels_not_convegent_yet = false;
} else {
ref_labels = cluster_labels;
}
}
// return cluster_labels;
return wrap(cluster_labels);
}
NumericVector logLikHMM(NumericVector transitionMatrix, NumericVector emissionArray,
NumericVector initialProbs, IntegerVector obsArray) {
IntegerVector eDims = emissionArray.attr("dim"); //m,p,r
IntegerVector oDims = obsArray.attr("dim"); //k,n,r
arma::colvec init(initialProbs.begin(),eDims[0], false);
arma::mat transition(transitionMatrix.begin(),eDims[0],eDims[0], false);
arma::cube emission(emissionArray.begin(), eDims[0], eDims[1], eDims[2], false);
arma::icube obs(obsArray.begin(), oDims[0], oDims[1], oDims[2], false);
arma::vec alpha(eDims[0]);
NumericVector ll(oDims[0]);
double tmp;
for(int k = 0; k < oDims[0]; k++){
for(int i=0; i < eDims[0]; i++){
alpha(i) = init(i);
for(int r = 0; r < oDims[2]; r++){
alpha(i) *= emission(i,obs(k,0,r),r);
}
}
tmp = sum(alpha);
ll(k) = log(tmp);
alpha /= tmp;
arma::vec alphatmp(eDims[0]);
for(int t = 1; t < oDims[1]; t++){
for(int i = 0; i < eDims[0]; i++){
alphatmp(i) = arma::dot(transition.col(i), alpha);
for(int r = 0; r < oDims[2]; r++){
alphatmp(i) *= emission(i,obs(k,t,r),r);
}
}
tmp = sum(alphatmp);
ll(k) += log(tmp);
alpha = alphatmp/tmp;
}
}
return ll;
}
