// [[Rcpp::export]] Rcpp::List subsetCounts(Rcpp::IntegerVector counts, Rcpp::IntegerVector start, Rcpp::IntegerVector width, Rcpp::LogicalVector strand){ if (start.length() != width.length() || start.length() != strand.length()) Rcpp::stop("provided vectors have different lengths..."); int nr = start.length(); int len = counts.length(); int tot = 0; int* S = start.begin(); int* W = width.begin(); for (int i = 0; i < nr; ++i){ int s = S[i] - 1; int w = W[i]; if (s < 0) Rcpp::stop("negative start positions are invalid"); if (s + w > len) Rcpp::stop("range exceeds the lengths of the counts vector"); tot += w; } Rcpp::IntegerVector res(tot); Rcpp::IntegerVector nstart(nr); Rcpp::IntegerVector nend(nr); int* R = res.begin(); int* C = counts.begin(); int* ST = strand.begin(); int* NS = nstart.begin(); int* NE = nend.begin(); int currpos = 0; for (int i = 0; i < nr; ++i){ NS[i] = currpos + 1; int w = W[i]; if (ST[i]) std::copy(C + S[i]-1, C + S[i]-1 + w, R + currpos); else std::reverse_copy(C + S[i]-1, C + S[i]-1 + w, R + currpos); currpos += w; NE[i] = currpos; } return List::create(_("counts")=res, _("starts")=nstart, _("ends")=nend); }
// [[Rcpp::export]] Rcpp::NumericMatrix testColPost(Rcpp::NumericMatrix post, Rcpp::List m2u, int nthreads){ Rcpp::IntegerVector values = Rcpp::as<Rcpp::IntegerVector>(m2u["values"]); Rcpp::IntegerVector map = Rcpp::as<Rcpp::IntegerVector>(m2u["map"]); if (post.ncol() != map.length()) Rcpp::stop("posteriors doesn't match with m2u"); Rcpp::NumericMatrix smallerPost(post.nrow(), values.length()); Vec<double> foo; NMPreproc preproc(asVec(values), asVec(map), foo); collapsePosteriors_core(asMat(smallerPost), asMat(post), preproc); return smallerPost; }
SEXP getAllFunnels(SEXP Rmpcross) { char* stackmem; { std::string error; { int nFounders; Rcpp::RObject mpcross_ = Rmpcross; bool valid = validateMPCross(mpcross_, nFounders, error, true, false, false); if(!valid) { goto signal_error; } Rcpp::List mpcross = Rmpcross; Rcpp::DataFrame pedigree(mpcross["pedigree"]); Rcpp::IntegerVector id = mpcross["id"]; int nFinals = id.length(); std::vector<int> fid = Rcpp::as<std::vector<int> >(mpcross["fid"]); Rcpp::IntegerMatrix output(id.length(), nFounders); std::vector<int> nIntercrossingGenerations; nIntercrossingGenerations.resize(nFinals, 0); //get number of intercrossing generations bool ok = intercrossingGenerations(pedigree, nFounders, id, nIntercrossingGenerations); if(!ok) { error = "Problem determining number of intercrossing generations"; goto signal_error; } //now get the actual funnels from the pedigree int funnel[16]; for(int i = 0; i < id.length(); i++) { ok = getFunnel(id[i], pedigree, fid, nIntercrossingGenerations[i], funnel, pedigree.nrows(), nFounders); if(!ok) { std::stringstream ss; ss << "Problem with pedigree, for individual number " << (i+1) << ", having id " << id[i]; error = ss.str(); goto signal_error; } for(int j = 0; j < nFounders; j++) output(i, j) = funnel[j]; } return output; } signal_error: stackmem = (char*)alloca(error.size() + 4); memset(stackmem, 0, error.size() + 4); memcpy(stackmem, error.c_str(), error.size()); } Rf_error(stackmem); return R_NilValue; }
// [[Rcpp::export]] Rcpp::IntegerVector testSortCounts(Rcpp::IntegerVector v){ Rcpp::IntegerVector res(v.length()); Vec<int> v2 = asVec(v); Vec<int> v3 = asVec(res); sortCounts(v2, v3); return res; }
// [[Rcpp::export]] Rcpp::IntegerMatrix quantileNorm(Rcpp::IntegerMatrix mat, Rcpp::IntegerVector ref, int nthreads=1, int seed=13){ if (mat.nrow() != ref.length()) Rcpp::stop("incompatible arrays..."); if (!std::is_sorted(ref.begin(), ref.end())) Rcpp::stop("ref must be sorted"); int ncol = mat.ncol(); int nrow = mat.nrow(); //allocate new matrix Rcpp::IntegerMatrix res(nrow, ncol); Mat<int> oldmat = asMat(mat); Mat<int> newmat = asMat(res); Vec<int> ref2 = asVec(ref); //allocate a seed for each column std::seed_seq sseq{seed}; std::vector<std::uint32_t> seeds(ncol); sseq.generate(seeds.begin(), seeds.end()); #pragma omp parallel num_threads(nthreads) { std::vector<std::pair<int, int> > storage(nrow);//pairs <value, index> #pragma omp for for (int col = 0; col < ncol; ++col){ std::mt19937 gen(seeds[col]); qtlnorm(oldmat.getCol(col), ref2, newmat.getCol(col), storage, gen); } } res.attr("dimnames") = mat.attr("dimnames"); return res; }
// [[Rcpp::export]] Rcpp::IntegerVector countInSubset(Rcpp::IntegerVector counts, Rcpp::IntegerVector start, Rcpp::IntegerVector width){ if (start.length() != width.length()) Rcpp::stop("provided vectors have different lengths..."); int nr = start.length(); int len = counts.length(); Rcpp::IntegerVector res(nr); int* R = res.begin(); int* C = counts.begin(); int* S = start.begin(); int* W = width.begin(); for (int i = 0; i < nr; ++i){ int s = S[i] - 1; int w = W[i]; if (s < 0) Rcpp::stop("negative start positions are invalid"); if (s + w > len) Rcpp::stop("range exceeds the lengths of the counts vector"); R[i] = sum(C + s, w); } return res; }
//Function to summarize results from BeQTL and return a dataframe // [[Rcpp::export]] Rcpp::DataFrame SumRes(const arma::mat & cormat, const arma::mat & errmat, const Rcpp::DataFrame SnpDF, const Rcpp::DataFrame Genedf, const int samplesize, const double tcutoff){ Rcpp::Rcout<<"Generating Tmat"<<std::endl; arma::mat tmat = sqrt(samplesize-2)*(cormat/(sqrt(1-square(cormat)))); Rcpp::Rcout<<"Finding strong t"<<std::endl; arma::uvec goods = find(abs(tmat)>tcutoff); Rcpp::Rcout<<"Generating matrix index"<<std::endl; arma::umat goodmat = Ind(tmat.n_rows,goods); Rcpp::Rcout<<"Subsetting tmat"<<std::endl; Rcpp::Rcout<<"This many good results"<<goodmat.n_rows<<std::endl; arma::vec tvec = tmat(goods); Rcpp::Rcout<<"Subsetting Errmat"<<std::endl; arma::vec errvec = errmat(goods); Rcpp::Rcout<<"Generating SNP and Gene lists"<<std::endl; Rcpp::IntegerVector GoodGenes = Rcpp::wrap(arma::conv_to<arma::ivec>::from(goodmat.col(0))); Rcpp::IntegerVector GoodSNPs = Rcpp::wrap(arma::conv_to<arma::ivec>::from(goodmat.col(1))); //Subset SNP anno Rcpp::CharacterVector SNPnames = SnpDF["rsid"]; SNPnames = SNPnames[GoodSNPs]; arma::ivec SNPchr = Rcpp::as<arma::ivec>(SnpDF["Chrom"]); SNPchr = SNPchr(goodmat.col(1)); arma::ivec SNPpos = Rcpp::as<arma::ivec>(SnpDF["Pos"]); SNPpos = SNPpos(goodmat.col(1)); //Subset Geneanno Rcpp::CharacterVector GeneNames = Genedf["Symbol"]; GeneNames = GeneNames[GoodGenes]; arma::ivec Genechr = Rcpp::as<arma::ivec>(Genedf["Chrom"]); Genechr = Genechr(goodmat.col(0)); arma::ivec Genestart = Rcpp::as<arma::ivec>(Genedf["Start"]); Genestart = Genestart(goodmat.col(0)); arma::ivec Genestop = Rcpp::as<arma::ivec>(Genedf["Stop"]); Genestop = Genestop(goodmat.col(0)); arma::ivec CisDist(GoodGenes.length()); Rcpp::Rcout<<"Calculating Cisdist"<<std::endl; CisDist = arma::min(arma::join_cols(abs(Genestop-SNPpos),abs(Genestart-SNPpos)),1); Rcpp::Rcout<<"CisDist Calculated"<<std::endl; CisDist.elem(find(Genechr!=SNPchr)).fill(-1); return Rcpp::DataFrame::create(Rcpp::Named("SNP")=SNPnames, Rcpp::Named("Gene")=GeneNames, Rcpp::Named("t-stat")=Rcpp::wrap(tvec), Rcpp::Named("err")=Rcpp::wrap(errvec), Rcpp::Named("CisDist")=Rcpp::wrap(CisDist)); }
//' The Gillespie algorithm for simulating continuous time Markov chains. //' //' This function is called by \code{\link{Simulate.EventSim}} //' //' @param start_states an integer vector giving the start states for each patient //' @param start_times a numeric vector containing the calendar time at which each patient is recruited //' @param n_state an integer, the number of states on the underlying DAG //' @param rates A list of \code{n_state * n_state * length(patientEndTime)} transition rates //' @param patientEndTimes The ith \code{n_state*n_state} block of rates represents the transition //' rate matrix until patient time patientEndTimes[i] //' @param calendarEndTimes The ith \code{n_state*n_state} block of rates represents the transition //' rate matrix until calendar time calendarEndTimes[i] //' @param shape The shape parameter for the edges in the DAG. A matrix where shape[i,j] is the Weibull //' shape parameter for the edge from node i to node j. If there is no edge between i and j //' then shape[i,j] = 0. //' @param resetEdges A vector (from1,to1,from2,to2,...) of edges for which if a subject traverses //' one of these edges then patient time switches are reset. See \code{SetIsResetEdge.ProgressionGraph} for further //' details //' @param duration The total (patient) time each subject is to be simulated //' @return A data frame with columns "id", "state" and "patient_transition_time" listing the (patient) time at //' which patients transition into new states. For example //' //' id state patient_transition_time //' 1 1 0.0 //' 1 2 1.4 //' //' patient 1 transitions to state 1 at time 0 (w.r.t. patient time) and then at time 1.4 transitions //' to state 2 //[[Rcpp::export]] Rcpp::DataFrame gillespie(Rcpp::IntegerVector start_states,Rcpp::NumericVector start_times, const int n_state,Rcpp::NumericVector rates, Rcpp::NumericVector patientEndTimes, Rcpp::NumericVector calendarEndTimes,Rcpp::NumericMatrix shape, Rcpp::NumericVector resetEdges, const double duration){ //set up output vectors std::vector<int> Id; std::vector<int> transition_to_states; std::vector<double> transition_times; //Random number generator Rcpp::RNGScope scope; //lots of validation and set up here Transitions transitions(n_state,rates,patientEndTimes,calendarEndTimes,shape,resetEdges); //for each subject for(R_len_t subject_id=0; subject_id != start_states.length(); ++subject_id){ //Initialize patient-specific variables int current_Id = subject_id+1; int current_state = start_states[subject_id]; SubjectTime subjectTime(start_times[subject_id]); //store subject recruitment in output vectors Id.push_back(current_Id); transition_to_states.push_back(current_state); transition_times.push_back(0); //get intial transition from current state double out_time=0; double time_left_before_switch = transitions.getNextSwitch(subjectTime); int proposed_new_state = transitions.ProposeNewState(out_time,subjectTime, current_state); //keep going until, no more rate switching and the rate leaving current state = 0 while(!(out_time == INFINITY && time_left_before_switch == INFINITY ) && subjectTime.getCurrentPatientTime() <= duration){ //std::cout << time_left_before_switch << " " << out_time << " " << subjectTime.getCurrentPatientTime() // << " " << proposed_new_state << std::endl; if(out_time >= time_left_before_switch || subjectTime.getCurrentPatientTime() + out_time > duration){ //subject switch rate matrices before transition subjectTime.IncreasePatientTime(time_left_before_switch); } else{ //subject transitions at time current_patient_time + out_time subjectTime.IncreasePatientTime(out_time); int old_state = current_state; current_state = proposed_new_state; if(current_state != old_state){ Id.push_back(current_Id); transition_to_states.push_back(current_state); transition_times.push_back(subjectTime.getCurrentPatientTime()); } //are we reseting the patient time switches (i.e. have we crossed //an edge with isResetEdge = TRUE?) if(transitions.resetPatientTimeForSwitches(old_state,current_state)){ subjectTime.ResetPatientSwitches(); } } proposed_new_state = transitions.ProposeNewState(out_time,subjectTime, current_state); time_left_before_switch = transitions.getNextSwitch(subjectTime ); //numerical fix if(time_left_before_switch < 1e-10){ subjectTime.IncreasePatientTime(1e-10); time_left_before_switch = transitions.getNextSwitch(subjectTime ); proposed_new_state = transitions.ProposeNewState(out_time,subjectTime, current_state); } } } return Rcpp::DataFrame::create(Rcpp::Named("id")= Id, Rcpp::Named("state") =transition_to_states, Rcpp::Named("patient_transition_time")=transition_times ); }