glmerResp::glmerResp(Rcpp::S4 xp) throw (std::runtime_error)
: merResp(xp),
d_fam(SEXP(xp.slot("family"))),
d_n( xp.slot("n")),
d_eta( xp.slot("eta")) {
updateWts();
}
SEXP rawSymmetricMatrixToDist(SEXP object)
{
BEGIN_RCPP
Rcpp::S4 rawSymmetric = object;
Rcpp::NumericVector levels = Rcpp::as<Rcpp::NumericVector>(rawSymmetric.slot("levels"));
Rcpp::CharacterVector markers = Rcpp::as<Rcpp::CharacterVector>(rawSymmetric.slot("markers"));
Rcpp::RawVector data = Rcpp::as<Rcpp::RawVector>(rawSymmetric.slot("data"));
R_xlen_t size = markers.size(), levelsSize = levels.size();
Rcpp::NumericVector result(size*(size - 1)/2, 0);
int counter = 0;
for(R_xlen_t row = 0; row < size; row++)
{
for(R_xlen_t column = row+1; column < size; column++)
{
int byte = data(column * (column + (R_xlen_t)1)/(R_xlen_t)2 + row);
if(byte == 255) result(counter) = std::numeric_limits<double>::quiet_NaN();
else result(counter) = levels(byte);
counter++;
}
}
result.attr("Size") = (int)size;
result.attr("Labels") = markers;
result.attr("Diag") = false;
result.attr("Upper") = false;
result.attr("class") = "dist";
return result;
END_RCPP
}
// construct cell type from equivalent class in R
CellType::CellType(unsigned id, const Rcpp::S4& type)
{
mID = id;
mName = Rcpp::as<std::string>(type.slot("name"));
mSize = Rcpp::as<double>(type.slot("size"));
mMinCycle = Rcpp::as<double>(type.slot("minCycle"));
mCellTypeClass = type;
}
// [[Rcpp::export]]
Rcpp::NumericVector marginal_theta(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model_(xmod) ;
Rcpp::S4 model = clone(model_) ;
Rcpp::S4 params=model.slot("mcmc.params") ;
Rcpp::S4 chains(model.slot("mcmc.chains")) ;
int S = params.slot("iter") ;
// Assume current values are the modes (in R, useModes(object) ensures this)
// List modes = model.slot("modes") ;
// NumericVector thetastar = as<NumericVector>(modes["theta"]) ;
List modes = model.slot("modes") ;
NumericVector theta_ = as<NumericVector>(modes["theta"]) ;
NumericVector thetastar=clone(theta_) ;
int K = thetastar.size() ;
NumericVector p_theta(S) ;
NumericVector muc = chains.slot("mu") ;
NumericVector tau2c = chains.slot("tau2") ;
NumericMatrix sigma2 = chains.slot("sigma2") ;
NumericVector tauc = sqrt(tau2c) ;
NumericVector tmp(K) ;
IntegerMatrix Z = chains.slot("z") ;
IntegerVector zz ;
double tau2_tilde ;
NumericVector sigma2_tilde(K) ;
// this should be updated for each iteration
NumericVector data_mean(K) ;
IntegerVector nn(K) ;
double post_prec;
double tau_n;
double mu_n;
double w1;
double w2;
for(int s=0; s < S; ++s){
zz = Z(s, _) ;
model.slot("z") = zz ;
nn = tableZ(K, zz) ;
data_mean = compute_means(model) ;
tau2_tilde = 1/tau2c[s] ;
sigma2_tilde = 1.0/sigma2(s, _) ;
//tmp = dnorm(thetastar, muc[s], tauc[s]) ;
double prod = 1.0;
for(int k = 0; k < K; ++k) {
post_prec = tau2_tilde + sigma2_tilde[k] * nn[k];
tau_n = sqrt(1/post_prec);
w1 = tau2_tilde/post_prec;
w2 = nn[k]*sigma2_tilde[k]/post_prec;
mu_n = w1*muc[s] + w2*data_mean[k];
tmp = dnorm(thetastar, mu_n, tau_n) ;
prod = prod * tmp[k] ;
}
p_theta[s] = prod ;
}
return p_theta ;
}
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
}
void parse_gb_feature_table(
Rcpp::S4& gb_feature,
const std::vector<std::string>& feature_string,
std::string& accession )
{
std::smatch m;
std::string this_line("");
std::vector<std::string> merged_lines;
// merge qualifier values that occupy more than one line into "merged_lines"
// Define qualifier position: Optional FT + blanks followed by forward slash
static const std::regex QUAL_POS("^(FT)?\\s+/");
static const std::regex TRANS("^translation=");
std::vector<std::string>::const_iterator s_it = std::begin(feature_string);
for ( ; s_it != std::end(feature_string); s_it++ ) {
std::regex_search( std::begin(*s_it), std::end(*s_it), m, QUAL_POS );
if ( m[0].matched ) {
merged_lines.push_back(this_line);
// If we have an embl file trim FT, whitespace and /
// If we have a gbk file trim whitespace and /
this_line = *s_it;
this_line = ltrim(this_line, "FT");
this_line = ltrim(this_line, " /");
this_line = rtrim(this_line, " \n\r\t");
} else {
std::string tmp = *s_it;
tmp = ltrim(tmp, "FT");
tmp = ltrim(tmp, " /");
tmp = rtrim(tmp, " \n\r\t");
if ( std::regex_search( this_line, m, TRANS ) ) {
// don't add whitespace when joining translations
this_line += tmp;
} else {
this_line += " " + tmp;
}
}
// Push the last qualifier
if ( s_it == std::end(feature_string) - 1 ) {
merged_lines.push_back(this_line);
}
}
// Get key
int begin_key = merged_lines[0].find_first_not_of(" ");
int end_key = merged_lines[0].find_first_of( " ", begin_key );
std::string key = merged_lines[0].substr( begin_key, end_key - 1 );
gb_feature.slot("key") = key;
// Get location
Rcpp::S4 gb_location = Rcpp::S4("gbLocation");
std::string gb_base_span = merged_lines[0].substr( end_key, merged_lines[0].length() - end_key );
parse_gb_location( gb_location, gb_base_span, accession );
gb_feature.slot("location") = gb_location;
merged_lines.erase( std::begin(merged_lines) );
gb_feature.slot("qualifiers") = parse_gb_qualifiers(merged_lines);
}
// [[Rcpp::export]]
Rcpp::NumericVector p_nu0_reduced(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model(xmod) ;
Rcpp::S4 mcmcp = model.slot("mcmc.params") ;
Rcpp::S4 chains = model.slot("mcmc.chains") ;
Rcpp::S4 hypp = model.slot("hyperparams") ;
List modes = model.slot("modes") ;
//
//
NumericVector x = model.slot("data") ;
int K = hypp.slot("k") ;
int S = mcmcp.slot("iter") ;
//
NumericVector p_=as<NumericVector>(modes["mixprob"]) ;
NumericVector theta_=as<NumericVector>(modes["theta"]) ;
NumericVector mu_=as<NumericVector>(modes["mu"]) ;
NumericVector tau2_=as<NumericVector>(modes["tau2"]) ;
IntegerVector nu0_=as<IntegerVector>(modes["nu0"]) ;
NumericVector sigma2_=as<NumericVector>(modes["sigma2"]) ;
NumericVector pstar = clone(p_) ;
NumericVector mustar = clone(mu_) ;
NumericVector tau2star = clone(tau2_) ;
NumericVector thetastar = clone(theta_) ;
NumericVector sigma2star = clone(sigma2_) ;
IntegerVector nu0=clone(nu0_) ;
NumericVector p_nu0(S) ;
int nu0star = nu0[0] ;
NumericVector s20chain = chains.slot("sigma2.0") ;
double betas = hypp.slot("beta") ;
//
// compute p(nu0*, ) from *normalized* probabilities
//
NumericVector d(100) ; // 100 is the maximum allowed value for nu_0
NumericVector lpnu0(100);
double prec = 0.0 ;
double lprec = 0.0 ;
for(int k = 0; k < K; k++) prec += 1.0/sigma2star[k] ;
for(int k = 0; k < K; k++) lprec += log(1.0/sigma2star[k]) ;
d = seq_len(100) ;
NumericVector y1(100) ;
NumericVector y2(100) ;
NumericVector y3(100) ;
for(int s = 0; s < S; ++s) {
y1 = K*(0.5*d*log(s20chain[s]*0.5*d) - lgamma(d*0.5)) ;
y2 = (0.5*d - 1.0) * lprec ;
y3 = d*(betas + 0.5*s20chain[s]*prec) ;
lpnu0 = y1 + y2 - y3 ;
NumericVector prob(100) ;
prob = exp(lpnu0) ; // - maxprob) ;
prob = prob/sum(prob) ; // this is now normalized
p_nu0[s] = prob[nu0star] ;
}
return p_nu0 ;
}
SEXP rawSymmetricMatrixSubsetByMatrix(SEXP object_, SEXP index_)
{
BEGIN_RCPP
Rcpp::S4 object;
try
{
object = object_;
}
catch(...)
{
throw std::runtime_error("Input object must be an S4 object");
}
Rcpp::RawVector data;
try
{
data = Rcpp::as<Rcpp::RawVector>(object.slot("data"));
}
catch(...)
{
throw std::runtime_error("Slot object@data must be a raw vector");
}
Rcpp::NumericVector levels;
try
{
levels = Rcpp::as<Rcpp::NumericVector>(object.slot("levels"));
}
catch(...)
{
throw std::runtime_error("Slot object@levels must be a numeric vector");
}
Rcpp::IntegerMatrix index;
try
{
index = index_;
}
catch(...)
{
throw std::runtime_error("Input index must be an integer matrix");
}
int nIndices = index.nrow();
Rcpp::NumericVector output(nIndices);
for(int row = 0; row < nIndices; row++)
{
R_xlen_t i = index(row, 0);
R_xlen_t j = index(row, 1);
if(i > j) std::swap(i, j);
output(row) = levels[data[(j*(j-(R_xlen_t)1))/(R_xlen_t)2 + i-(R_xlen_t)1]];
}
return output;
END_RCPP
}
reModule::reModule(Rcpp::S4 xp)
: d_L( S4(clone(SEXP(xp.slot("L"))))),
d_Lambda(S4(clone(SEXP(xp.slot("Lambda"))))),
d_Zt( S4(xp.slot("Zt"))),
d_Lind( xp.slot("Lind")),
d_lower( xp.slot("lower")),
d_theta( xp.slot("theta")),
d_u0( d_L.n),
d_incr( d_L.n),
d_u( d_L.n),
d_cu( d_L.n) {
d_Ut = (CHM_SP)NULL;
}
double cpp_luT(
Rcpp::S4 xR,
Rcpp::S4 dR) {
const bool BisVCL=1;
const int ctx_id = INTEGER(xR.slot(".context_index"))[0]-1;
std::shared_ptr<viennacl::matrix<T> > vclX = getVCLptr<T>(xR.slot("address"), BisVCL, ctx_id);
std::shared_ptr<viennacl::vector_base<T> > vclD = getVCLVecptr<T>(dR.slot("address"), BisVCL, ctx_id);
return(luT(*vclX, *vclD));
}
//Returns the value of any((object@data >= length(object@levels)) & object@data != as.raw(255))
SEXP checkRawSymmetricMatrix(SEXP rawSymmetric_)
{
BEGIN_RCPP
Rcpp::S4 rawSymmetric = rawSymmetric_;
Rcpp::NumericVector levels = Rcpp::as<Rcpp::NumericVector>(rawSymmetric.slot("levels"));
Rcpp::RawVector data = Rcpp::as<Rcpp::RawVector>(rawSymmetric.slot("data"));
R_xlen_t size = data.size(), levelsSize = levels.size();
for(R_xlen_t i = 0; i < size; i++)
{
if(data[i] >= levelsSize && data[i] != 0xff) return Rcpp::wrap(true);
}
return Rcpp::wrap(false);
END_RCPP
}
merResp::merResp(Rcpp::S4 xp) throw (std::runtime_error)
: d_y( xp.slot("y")),
d_weights( xp.slot("weights")),
d_offset( xp.slot("offset")),
d_mu( d_y.size(), 0.),
d_sqrtrwt( d_y.size()),
d_wtres( d_y.size()),
d_sqrtXwt(d_y.size(), d_offset.size()/d_y.size()) {
int n = d_y.size(), os = d_offset.size();
if (d_mu.size() != n || d_weights.size() != n || d_sqrtrwt.size() != n)
throw std::runtime_error("y, mu, sqrtrwt and weights slots must have equal lengths");
if (os < 1 || os % n)
throw std::runtime_error("length(offset) must be a positive multiple of length(y)");
init();
}
SEXP constructDissimilarityMatrix(SEXP object, SEXP clusters_)
{
BEGIN_RCPP
Rcpp::S4 rawSymmetric = object;
Rcpp::NumericVector levels = Rcpp::as<Rcpp::NumericVector>(rawSymmetric.slot("levels"));
Rcpp::CharacterVector markers = Rcpp::as<Rcpp::CharacterVector>(rawSymmetric.slot("markers"));
Rcpp::RawVector data = Rcpp::as<Rcpp::RawVector>(rawSymmetric.slot("data"));
int nMarkers = markers.size();
std::vector<double> levelsCopied = Rcpp::as<std::vector<double> >(levels);
std::vector<int> permutation(nMarkers);
for(int i = 0; i < nMarkers; i++) permutation[i] = i;
return constructDissimilarityMatrixInternal(&(data(0)), levelsCopied, nMarkers, clusters_, 0, permutation);
END_RCPP
}
SEXP assignRawSymmetricMatrixFromEstimateRF(SEXP destination_, SEXP rowIndices_, SEXP columnIndices_, SEXP source_)
{
BEGIN_RCPP
Rcpp::S4 destination = destination_;
Rcpp::RawVector source = source_;
Rcpp::RawVector destinationData = destination.slot("data");
Rcpp::IntegerVector rowIndices = rowIndices_;
Rcpp::IntegerVector columnIndices = columnIndices_;
if(&(source(0)) == &(destinationData(0)))
{
throw std::runtime_error("Source and destination cannot be the same in assignRawSymmetricMatrixDiagonal");
}
std::vector<int> markerRows, markerColumns;
markerRows = Rcpp::as<std::vector<int> >(rowIndices);
markerColumns = Rcpp::as<std::vector<int> >(columnIndices);
if(countValuesToEstimate(markerRows, markerColumns) != (unsigned long long)source.size())
{
throw std::runtime_error("Mismatch between index length and source object size");
}
triangularIterator iterator(markerRows, markerColumns);
R_xlen_t counter = 0;
for(; !iterator.isDone(); iterator.next())
{
std::pair<int, int> markerPair = iterator.get();
R_xlen_t markerRow = markerPair.first, markerColumn = markerPair.second;
destinationData((markerColumn*(markerColumn-(R_xlen_t)1))/(R_xlen_t)2 + (markerRow - (R_xlen_t)1)) = source(counter);
counter++;
}
return R_NilValue;
END_RCPP
}
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::NumericVector p_sigma2_batch(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model_(xmod) ;
Rcpp::S4 model = clone(model_) ;
Rcpp::S4 chains=model.slot("mcmc.chains") ;
Rcpp::S4 params=model.slot("mcmc.params") ;
int S = params.slot("iter") ;
List modes = model.slot("modes") ;
NumericMatrix sigma2_ = as<NumericMatrix>(modes["sigma2"]) ;
NumericMatrix theta_ = as<NumericMatrix>(modes["theta"]) ;
NumericMatrix sigma2star=clone(sigma2_) ;
NumericMatrix thetastar=clone(theta_) ;
int K = thetastar.ncol() ;
int B = thetastar.nrow() ;
NumericMatrix prec(B, K) ;
NumericVector p_prec(S) ;
NumericVector tmp(K) ;
NumericVector nu0 (1) ;
NumericVector s20 (1) ;
//
// These chains have already been updated
//
NumericVector nu0chain = chains.slot("nu.0") ;
NumericVector s20chain = chains.slot("sigma2.0") ;
NumericVector d(1) ;
//
// Run reduced Gibbs -- theta is fixed at modal ordinate
//
for(int k=0; k < K; ++k){
prec(_, k) = 1.0/sigma2star(_, k) ;
}
for(int s=0; s < S; ++s){
s20 = s20chain[s] ;
nu0 = nu0chain[s] ;
double total = 1.0 ;
for(int b=0; b < B; ++b) {
tmp = dgamma(prec(b, _), 0.5*nu0[0], 2.0 / (nu0[0]*s20[0])) ;
for(int k = 0; k < K; ++k){
//total = log(tmp[k]) ;
total = total * tmp[k] ;
}
}
p_prec[s] = total ;
}
return p_prec ;
}
Rcpp::NumericVector marginal_sigma2(Rcpp::S4 xmod, Rcpp::S4 mcmcp) {
RNGScope scope ;
Rcpp::S4 model_(xmod) ;
Rcpp::S4 model = clone(model_) ;
Rcpp::S4 params(mcmcp) ;
int S = params.slot("iter") ;
// Assume current values are the modes (in R, useModes(object) ensures this)
List modes = model.slot("modes") ;
NumericVector sigma2_ = as<NumericVector>(modes["sigma2"]) ;
NumericVector theta_ = as<NumericVector>(modes["theta"]) ;
//NumericVector sigma2_ = model.slot("sigma2") ;
NumericVector sigma2star = clone(sigma2_) ;
NumericVector thetastar = clone(theta_) ;
NumericVector prec = pow(sigma2star, -1.0) ;
int K = prec.size() ;
NumericVector logp_prec(S) ;
//
// Run reduced Gibbs -- theta is fixed at modal ordinate
//
Rcpp::S4 chains(model.slot("mcmc.chains")) ;
NumericVector tmp(K) ;
NumericVector nu0 = chains.slot("nu.0") ;
NumericVector s20 = chains.slot("sigma2.0") ;
for(int s=0; s < S; ++s){
model.slot("z") = update_z(model) ;
model.slot("data.mean") = compute_means(model) ;
model.slot("data.prec") = compute_prec(model) ;
// model.slot("theta") = update_theta(model) ; Do not update theta!
model.slot("sigma2") = update_sigma2(model) ;
model.slot("pi") = update_p(model) ;
model.slot("mu") = update_mu(model) ;
model.slot("tau2") = update_tau2(model) ;
model.slot("nu.0") = update_nu0(model) ;
model.slot("sigma2.0") = update_sigma2_0(model) ;
nu0 = model.slot("nu.0") ;
s20 = model.slot("sigma2.0") ;
tmp = dgamma(prec, 0.5*nu0[0], 2.0 / (nu0[0]*s20[0])) ;
double total = 0.0 ;
for(int k = 0; k < K; ++k){
total += log(tmp[k]) ;
}
logp_prec[s] = total ;
}
return logp_prec ;
}
// [[Rcpp::export]]
Rcpp::NumericVector p_s20_reduced(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model(xmod) ;
Rcpp::S4 mcmcp = model.slot("mcmc.params") ;
Rcpp::S4 chains = model.slot("mcmc.chains") ;
Rcpp::S4 hypp = model.slot("hyperparams") ;
List modes = model.slot("modes") ;
//
//
NumericVector x = model.slot("data") ;
int K = hypp.slot("k") ;
int S = mcmcp.slot("iter") ;
//
NumericVector p_=as<NumericVector>(modes["mixprob"]) ;
NumericVector theta_=as<NumericVector>(modes["theta"]) ;
NumericVector mu_=as<NumericVector>(modes["mu"]) ;
NumericVector tau2_=as<NumericVector>(modes["tau2"]) ;
IntegerVector nu0_=as<IntegerVector>(modes["nu0"]) ;
NumericVector sigma2_=as<NumericVector>(modes["sigma2"]) ;
NumericVector s20_=as<NumericVector>(modes["sigma2.0"]) ;
NumericVector pstar = clone(p_) ;
NumericVector mustar = clone(mu_) ;
NumericVector tau2star = clone(tau2_) ;
NumericVector thetastar = clone(theta_) ;
NumericVector sigma2star = clone(sigma2_) ;
NumericVector s20star = clone(s20_) ;
IntegerVector nu0=clone(nu0_) ;
double nu0star = nu0[0] ;
NumericVector p_s20(S) ;
double a = hypp.slot("a") ;
double b = hypp.slot("b") ;
double a_k = a + 0.5*K*nu0star ;
double b_k = 0.0;
for (int k=0; k < K; k++) {
b_k += 0.5*nu0star/sigma2star[k];
}
b_k += b ;
p_s20 = dgamma(s20star, a_k, 1.0/b_k) ;
return p_s20 ;
}
// [[Rcpp::export]]
Rcpp::NumericVector p_tau_reduced(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model(xmod) ;
Rcpp::S4 mcmcp = model.slot("mcmc.params") ;
Rcpp::S4 chains = model.slot("mcmc.chains") ;
Rcpp::S4 hypp = model.slot("hyperparams") ;
List modes = model.slot("modes") ;
//
//
NumericVector x = model.slot("data") ;
int K = hypp.slot("k") ;
int S = mcmcp.slot("iter") ;
int N = x.size() ;
//
NumericVector p_=as<NumericVector>(modes["mixprob"]) ;
NumericVector theta_=as<NumericVector>(modes["theta"]) ;
NumericVector mu_=as<NumericVector>(modes["mu"]) ;
NumericVector tau2_=as<NumericVector>(modes["tau2"]) ;
NumericVector pstar = clone(p_) ;
NumericVector mustar = clone(mu_) ;
NumericVector tau2star = clone(tau2_) ;
NumericVector thetastar = clone(theta_) ;
IntegerMatrix Z = chains.slot("z") ;
IntegerVector zz(N) ;
NumericVector p_tau(S) ;
double m2_0 = hypp.slot("m2.0") ;
double eta_0 = hypp.slot("eta.0") ;
double eta_k = eta_0 + K ;
NumericVector s2_k(1) ;
for(int k = 0; k < K; k++) s2_k[0] += pow(thetastar[k] - mustar[0], 2.0) ;
NumericVector m2_k(1) ;
m2_k[0] = 1/eta_k * (eta_0 * m2_0 + s2_k[0]) ;
// NumericVector tmp(1) ;
// for(int s = 0; s < S; ++s) {
// tmp = dgamma(1.0/tau2star, 0.5 * eta_k, 1.0/(0.5 * eta_k * m2_k[0])) ;
// p_tau[s] = tmp ;
// }
p_tau = dgamma(1.0/tau2star, 0.5 * eta_k, 1.0/(0.5 * eta_k * m2_k[0])) ;
return p_tau ;
}
// [[Rcpp::export]]
Rcpp::NumericVector p_theta_batch(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model_(xmod) ;
Rcpp::S4 model = clone(model_) ;
Rcpp::S4 params=model.slot("mcmc.params") ;
Rcpp::S4 chains(model.slot("mcmc.chains")) ;
int S = params.slot("iter") ;
// Assume current values are the modes (in R, useModes(object) ensures this)
// List modes = model.slot("modes") ;
// NumericVector thetastar = as<NumericVector>(modes["theta"]) ;
List modes = model.slot("modes") ;
NumericMatrix theta_ = as<NumericMatrix>(modes["theta"]) ;
NumericMatrix thetastar=clone(theta_) ;
int K = thetastar.ncol() ;
int B = thetastar.nrow() ;
NumericVector p_theta(S) ;
NumericMatrix muc = chains.slot("mu") ;
NumericMatrix tau2c = chains.slot("tau2") ;
NumericVector theta(1) ;
NumericVector tmp(1) ;
NumericVector d(1) ;
double tau ;
double mu ;
for(int s = 0; s < S; ++s){
d = 1.0 ;
for(int k = 0; k < K; ++k){
tau = sqrt(tau2c(s, k)) ;
mu = muc(s, k) ;
for(int b = 0; b < B; ++b){
theta[0] = thetastar(b, k) ;
tmp = dnorm(theta, mu, tau) ;
d = d * tmp[0] ;
}
}
p_theta[s] = d[0] ;
}
return p_theta ;
}
// [[Rcpp::export]]
Rcpp::NumericVector p_pmix_reduced(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model(xmod) ;
Rcpp::S4 mcmcp = model.slot("mcmc.params") ;
Rcpp::S4 chains = model.slot("mcmc.chains") ;
Rcpp::S4 hypp = model.slot("hyperparams") ;
List modes = model.slot("modes") ;
//
//
NumericVector x = model.slot("data") ;
int K = hypp.slot("k") ;
int S = mcmcp.slot("iter") ;
int N = x.size() ;
//
NumericVector p_=as<NumericVector>(modes["mixprob"]) ;
NumericVector pstar = clone(p_) ;
NumericMatrix Z = chains.slot("z") ;
NumericVector alpha = hypp.slot("alpha") ;
NumericVector pmix(S) ;
//
// Run reduced Gibbs -- theta,sigma2 fixed at modal ordinates
//
NumericVector h(N) ;
NumericVector alpha_n(K) ;
NumericVector tmp(1) ;
for(int s=0; s < S; ++s){
h = Z(s, _ ) ;
for(int k = 0 ; k < K; ++k){
alpha_n[k] = sum(h == k+1) + alpha[k] ;
}
tmp = log_ddirichlet_(pstar, alpha_n) ;
pmix[s] = exp(tmp[0]) ;
}
// return tmp ;
return pmix ;
}
// [[Rcpp::export]]
Rcpp::NumericVector p_mu_reduced(Rcpp::S4 xmod) {
RNGScope scope ;
Rcpp::S4 model(xmod) ;
Rcpp::S4 mcmcp = model.slot("mcmc.params") ;
Rcpp::S4 chains = model.slot("mcmc.chains") ;
Rcpp::S4 hypp = model.slot("hyperparams") ;
List modes = model.slot("modes") ;
//
//
NumericVector x = model.slot("data") ;
int K = hypp.slot("k") ;
int S = mcmcp.slot("iter") ;
int N = x.size() ;
//
NumericVector p_=as<NumericVector>(modes["mixprob"]) ;
NumericVector theta_=as<NumericVector>(modes["theta"]) ;
NumericVector mu_=as<NumericVector>(modes["mu"]) ;
NumericVector pstar = clone(p_) ;
NumericVector mustar = clone(mu_) ;
NumericVector thetastar = clone(theta_) ;
IntegerMatrix Z = chains.slot("z") ;
NumericVector tau2chain = chains.slot("tau2") ;
IntegerVector zz(N) ;
IntegerVector nn(K) ;
NumericVector mu0=hypp.slot("mu.0") ;
double mu_0 = mu0[0] ;
NumericVector tau2_0 = hypp.slot("tau2.0") ;
double tau20_tilde = 1.0/tau2_0[0] ;
double mu_k ;
NumericVector tau2_tilde = 1.0/tau2chain ;
double w1 ;
double w2 ;
double tau_k ;
NumericVector p_mu(S) ;
NumericVector tmp(1) ;
for(int s = 0; s < S; ++s){
zz = Z(s, _) ;
nn = tableZ(K, zz) ;
double total = 0.0 ;
double thetabar = 0.0 ;
for(int k = 0; k < K; k++) total += nn[k] ;
for(int k = 0; k < K; k++) thetabar += nn[k] * thetastar[k] / total ;
double post_prec = tau20_tilde + K*tau2_tilde[s] ;
w1 = tau20_tilde/post_prec ;
w2 = K*tau2_tilde[s]/post_prec ;
mu_k = w1*mu_0 + w2*thetabar ;
tau_k = sqrt(1.0/post_prec) ;
tmp = dnorm(mustar, mu_k, tau_k) ;
p_mu[s] = tmp[0] ;
}
return p_mu ;
}
void graphConvert(SEXP graph_sexp, residualConnectivity::context::inputGraph& boostGraph, std::vector<residualConnectivity::context::vertexPosition>& vertexCoordinates)
{
Rcpp::RObject graph = Rcpp::as<Rcpp::RObject>(graph_sexp);
std::string className = Rcpp::as<std::string>(graph.attr("class"));
Rcpp::NumericMatrix vertexCoordinates_matrix;
if(className == "igraph")
{
Rcpp::Environment igraphEnv("package:igraph");
Rcpp::Function isDirected = igraphEnv["is_directed"];
if(Rcpp::as<bool>(isDirected(graph)))
{
throw std::runtime_error("Input `graph' must be undirected");
}
Rcpp::Function layoutAuto = igraphEnv["layout.auto"];
vertexCoordinates_matrix = layoutAuto(graph);
igraphConvert(graph_sexp, boostGraph);
}
else if(className == "graphNEL" || className == "graphAM")
{
Rcpp::S4 graphS4 = Rcpp::as<Rcpp::S4>(graph);
Rcpp::S4 renderInfo = Rcpp::as<Rcpp::S4>(graphS4.slot("renderInfo"));
Rcpp::List nodes = Rcpp::as<Rcpp::List>(renderInfo.slot("nodes"));
Rcpp::Function length("length"), cbind("cbind");
if(Rcpp::as<int>(length(nodes)) > 0)
{
vertexCoordinates_matrix = Rcpp::as<Rcpp::NumericMatrix>(cbind(nodes["nodeX"], nodes["nodeY"]));
}
if(className == "graphNEL") graphNELConvert(graph_sexp, boostGraph);
else graphAMConvert(graph_sexp, boostGraph);
}
else
{
throw std::runtime_error("Input graph must have class \"igraph\", \"graphAM\" or \"graphNEL\"");
}
std::size_t nVertexCoordinates = vertexCoordinates_matrix.nrow();
vertexCoordinates.clear();
vertexCoordinates.reserve(nVertexCoordinates);
for(std::size_t i = 0; i < nVertexCoordinates; i++)
{
vertexCoordinates.push_back(residualConnectivity::context::vertexPosition((residualConnectivity::context::vertexPosition::first_type)vertexCoordinates_matrix((int)i, 0), (residualConnectivity::context::vertexPosition::second_type)vertexCoordinates_matrix((int)i, 1)));
}
}
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
}
predModule::predModule(Rcpp::S4& xp)
: d_coef(Rcpp::clone(SEXP(xp.slot("coef")))),
d_Vtr( d_coef.size()) {
}
sPredModule::sPredModule(Rcpp::S4 xp, int n)
: predModule( xp),
d_X( Rcpp::S4(xp.slot("X"))),
d_fac( Rcpp::S4(xp.slot("fac"))) {
d_V = (CHM_SP)NULL;
}
dPredModule::dPredModule(Rcpp::S4 xp, int n)
: predModule( xp),
d_X( Rcpp::S4(xp.slot("X"))),
d_V( n, d_X.ncol()),
d_fac( Rcpp::S4(xp.slot("fac"))) {
}
//' rcpp_get_polygons
//'
//' Extracts all polygons from an overpass API query
//'
//' @param st Text contents of an overpass API query
//' @return A \code{SpatialLinesDataFrame} contains all polygons and associated data
// [[Rcpp::export]]
Rcpp::S4 rcpp_get_polygons (const std::string& st)
{
#ifdef DUMP_INPUT
{
std::ofstream dump ("./get-polygons.xml");
if (dump.is_open())
{
dump.write (st.c_str(), st.size());
}
}
#endif
XmlPolys xml (st);
const std::map <osmid_t, Node>& nodes = xml.nodes ();
const std::map <osmid_t, OneWay>& ways = xml.ways ();
const std::vector <Relation>& rels = xml.relations ();
int count = 0;
float xmin = FLOAT_MAX, xmax = -FLOAT_MAX,
ymin = FLOAT_MAX, ymax = -FLOAT_MAX;
std::vector <float> lons, lats;
std::unordered_set <std::string> idset; // see TODO below
std::vector <std::string> colnames, rownames, polynames;
std::set <std::string> varnames;
Rcpp::List dimnames (0), dummy_list (0);
Rcpp::NumericMatrix nmat (Rcpp::Dimension (0, 0));
idset.clear ();
colnames.push_back ("lon");
colnames.push_back ("lat");
varnames.insert ("name");
// other varnames added below
/*
* NOTE: Nodes are first loaded into the 2 vectors of (lon, lat), and these
* are then copied into nmat. This intermediate can be avoided by loading
* directly into nmat using direct indexing rather than iterators, however
* this does *NOT* make the routine any faster, and so the current version
* which more safely uses iterators is kept instead.
*/
Rcpp::Environment sp_env = Rcpp::Environment::namespace_env ("sp");
Rcpp::Function Polygon = sp_env ["Polygon"];
Rcpp::Language polygons_call ("new", "Polygons");
Rcpp::S4 polygons;
/*
* Polygons are extracted from the XmlPolys class in three setps:
* 1. Get the names of all polygons that are part of multipolygon relations
* 2. Get the names of any remaining ways that are polygonal (start == end)
* 3. From the resultant list, extract the actual polygonal ways
*
* NOTE: OSM polygons are stored as ways, and thus all objects in the class
* xmlPolys are rightly referred to as ways. Here within this Rcpp function,
* these are referred to as Polygons, but the iteration is over the actual
* polygonal ways.
*/
// Step#1
std::set <osmid_t> the_ways; // Set will only insert unique values
for (auto it = rels.begin (); it != rels.end (); ++it)
for (auto itw = (*it).ways.begin (); itw != (*it).ways.end (); ++itw)
{
assert (ways.find (itw->first) != ways.end ());
the_ways.insert (itw->first);
}
// Step#2
//const std::map <osmid_t, OneWay>& ways = xml.ways ();
for (auto it = ways.begin (); it != ways.end (); ++it)
{
if (the_ways.find ((*it).first) == the_ways.end ())
if ((*it).second.nodes.begin () == (*it).second.nodes.end ())
the_ways.insert ((*it).first);
}
// Step#2b - Erase any ways that contain no data (should not happen).
for (auto it = the_ways.begin (); it != the_ways.end (); )
{
auto itw = ways.find (*it);
if (itw->second.nodes.size () == 0)
it = the_ways.erase (it);
else
++it;
}
Rcpp::List polyList (the_ways.size ());
// Step#3 - Extract and store the_ways
for (auto it = the_ways.begin (); it != the_ways.end (); ++it)
{
auto itw = ways.find (*it);
// Collect all unique keys
std::for_each (itw->second.key_val.begin (),
itw->second.key_val.end (),
[&](const std::pair <std::string, std::string>& p)
{
varnames.insert (p.first);
});
/*
* The following lines check for duplicate way IDs -- which do very
* occasionally occur -- and ensures unique values as required by 'sp'
* through appending decimal digits to <osmid_t> OSM IDs.
*/
std::string id = std::to_string (itw->first);
int tempi = 0;
while (idset.find (id) != idset.end ())
id = std::to_string (itw->first) + "." + std::to_string (tempi++);
idset.insert (id);
polynames.push_back (id);
// Then iterate over nodes of that way and store all lat-lons
size_t n = itw->second.nodes.size ();
lons.clear ();
lats.clear ();
rownames.clear ();
lons.reserve (n);
lats.reserve (n);
rownames.reserve (n);
for (auto itn = itw->second.nodes.begin ();
itn != itw->second.nodes.end (); ++itn)
{
// TODO: Propoer exception handler
assert (nodes.find (*itn) != nodes.end ());
lons.push_back (nodes.find (*itn)->second.lon);
lats.push_back (nodes.find (*itn)->second.lat);
rownames.push_back (std::to_string (*itn));
}
xmin = std::min (xmin, *std::min_element (lons.begin(), lons.end()));
xmax = std::max (xmax, *std::max_element (lons.begin(), lons.end()));
ymin = std::min (ymin, *std::min_element (lats.begin(), lats.end()));
ymax = std::max (ymax, *std::max_element (lats.begin(), lats.end()));
nmat = Rcpp::NumericMatrix (Rcpp::Dimension (lons.size (), 2));
std::copy (lons.begin (), lons.end (), nmat.begin ());
std::copy (lats.begin (), lats.end (), nmat.begin () + lons.size ());
// This only works with push_back, not with direct re-allocation
dimnames.push_back (rownames);
dimnames.push_back (colnames);
nmat.attr ("dimnames") = dimnames;
dimnames.erase (0, dimnames.size());
//Rcpp::S4 poly = Rcpp::Language ("Polygon", nmat).eval ();
Rcpp::S4 poly = Polygon (nmat);
dummy_list.push_back (poly);
polygons = polygons_call.eval ();
polygons.slot ("Polygons") = dummy_list;
polygons.slot ("ID") = id;
polyList [count++] = polygons;
dummy_list.erase (0);
} // end for it over the_ways
polyList.attr ("names") = polynames;
// Store all key-val pairs in one massive DF
int nrow = the_ways.size (), ncol = varnames.size ();
Rcpp::CharacterVector kv_vec (nrow * ncol, Rcpp::CharacterVector::get_na ());
int namecoli = std::distance (varnames.begin (), varnames.find ("name"));
for (auto it = the_ways.begin (); it != the_ways.end (); ++it)
{
int rowi = std::distance (the_ways.begin (), it);
auto itw = ways.find (*it);
kv_vec (namecoli * nrow + rowi) = itw->second.name;
for (auto kv_iter = itw->second.key_val.begin ();
kv_iter != itw->second.key_val.end (); ++kv_iter)
{
const std::string& key = (*kv_iter).first;
auto ni = varnames.find (key); // key must exist in varnames!
int coli = std::distance (varnames.begin (), ni);
kv_vec (coli * nrow + rowi) = (*kv_iter).second;
}
}
Rcpp::Language sp_polys_call ("new", "SpatialPolygonsDataFrame");
Rcpp::S4 sp_polys = sp_polys_call.eval ();
sp_polys.slot ("polygons") = polyList;
sp_polys.slot ("bbox") = rcpp_get_bbox (xmin, xmax, ymin, ymax);
Rcpp::Language crs_call ("new", "CRS");
Rcpp::S4 crs = crs_call.eval ();
crs.slot ("projargs") = "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0";
sp_polys.slot ("proj4string") = crs;
Rcpp::CharacterMatrix kv_mat (nrow, ncol, kv_vec.begin());
Rcpp::DataFrame kv_df = kv_mat;
kv_df.attr ("names") = varnames;
sp_polys.slot ("data") = kv_df;
return sp_polys;
}
/* This function specifically checks whether the observed data is consistent with the *pedigree*. It assumes that every observed value in the finals is already valid - That is, every observed value contained in the finals is also listed as a possibility in the hetData object
*/
void estimateRFCheckFunnels(Rcpp::IntegerMatrix finals, Rcpp::IntegerMatrix founders, Rcpp::List hetData, Rcpp::S4 pedigree, std::vector<int>& intercrossingGenerations, std::vector<std::string>& warnings, std::vector<std::string>& errors, std::vector<funnelType>& allFunnels, std::vector<funnelType>& lineFunnels)
{
Rcpp::CharacterVector pedigreeLineNames = Rcpp::as<Rcpp::CharacterVector>(pedigree.slot("lineNames"));
//We make a copy of the pedigree line names and sort it (otherwise the std::find relating to pedigreeLineNames is prohibitive)
std::vector<pedigreeLineStruct> sortedLineNames;
sortPedigreeLineNames(pedigreeLineNames, sortedLineNames);
Rcpp::IntegerVector mother = Rcpp::as<Rcpp::IntegerVector>(pedigree.slot("mother"));
Rcpp::IntegerVector father = Rcpp::as<Rcpp::IntegerVector>(pedigree.slot("father"));
bool warnImproperFunnels = Rcpp::as<bool>(pedigree.slot("warnImproperFunnels"));
Rcpp::CharacterVector finalNames = Rcpp::as<Rcpp::CharacterVector>(Rcpp::as<Rcpp::List>(finals.attr("dimnames"))[0]);
Rcpp::CharacterVector markerNames = Rcpp::as<Rcpp::CharacterVector>(Rcpp::as<Rcpp::List>(finals.attr("dimnames"))[1]);
int nFinals = finals.nrow(), nFounders = founders.nrow(), nMarkers = finals.ncol();
if(nFounders != 2 && nFounders != 4 && nFounders != 8 && nFounders != 16)
{
throw std::runtime_error("Number of founders must be 2, 4, 8, or 16");
}
xMajorMatrix<int> foundersToMarkerAlleles(nFounders, nFounders, nMarkers, -1);
for(int markerCounter = 0; markerCounter < nMarkers; markerCounter++)
{
Rcpp::IntegerMatrix currentMarkerHetData = hetData(markerCounter);
for(int founderCounter1 = 0; founderCounter1 < nFounders; founderCounter1++)
{
for(int founderCounter2 = 0; founderCounter2 < nFounders; founderCounter2++)
{
int markerAllele1 = founders(founderCounter1, markerCounter);
int markerAllele2 = founders(founderCounter2, markerCounter);
for(int hetDataRowCounter = 0; hetDataRowCounter < currentMarkerHetData.nrow(); hetDataRowCounter++)
{
if(markerAllele1 == currentMarkerHetData(hetDataRowCounter, 0) && markerAllele2 == currentMarkerHetData(hetDataRowCounter, 1))
{
foundersToMarkerAlleles(founderCounter1, founderCounter2, markerCounter) = currentMarkerHetData(hetDataRowCounter, 2);
}
}
}
}
}
std::vector<long> individualsToCheckFunnels;
for(long finalCounter = 0; finalCounter < nFinals; finalCounter++)
{
individualsToCheckFunnels.clear();
std::string currentLineName = Rcpp::as<std::string>(finalNames(finalCounter));
std::vector<pedigreeLineStruct>::iterator findLineName = std::lower_bound(sortedLineNames.begin(), sortedLineNames.end(), pedigreeLineStruct(currentLineName, -1));
if(findLineName == sortedLineNames.end() || findLineName->lineName != currentLineName)
{
std::stringstream ss;
ss << "Unable to find line number " << finalCounter << " named " << finalNames(finalCounter) << " in pedigree";
throw std::runtime_error(ss.str().c_str());
}
int pedigreeRow = findLineName->index;
//This vector lists all the founders that are ancestors of the current line. This may comprise any number - E.g. if we have an AIC line descended from funnels 1,2,1,2 and 2,3,2,3 then this vector is going it contain 1,2,3
std::vector<int> representedFounders;
if(intercrossingGenerations[finalCounter] == 0)
{
individualsToCheckFunnels.push_back(pedigreeRow);
}
else
{
try
{
getAICParentLines(mother, father, pedigreeRow, intercrossingGenerations[finalCounter], individualsToCheckFunnels);
}
catch(...)
{
std::stringstream ss;
ss << "Error while attempting to trace intercrossing lines for line " << finalNames(finalCounter);
errors.push_back(ss.str());
goto nextLine;
}
}
//Now we know the lines for which we need to check the funnels from the pedigree (note: We don't necessarily have genotype data for all of these, it's purely a pedigree check)
//Fixed length arrays to store funnels. If we have less than 16 founders then part of this is garbage and we don't use that bit....
funnelType funnel, copiedFunnel;
for(std::vector<long>::iterator i = individualsToCheckFunnels.begin(); i != individualsToCheckFunnels.end(); i++)
{
try
{
getFunnel(*i, mother, father, &(funnel.val[0]), nFounders);
}
catch(...)
{
std::stringstream ss;
ss << "Attempting to trace pedigree for line " << finalNames(finalCounter) << ": Unable to get funnel for line " << pedigreeLineNames(*i);
errors.push_back(ss.str());
goto nextLine;
}
//insert these founders into the vector containing all the represented founders
representedFounders.insert(representedFounders.end(), &(funnel.val[0]), &(funnel.val[0]) + nFounders);
//Copy the funnel
memcpy(&copiedFunnel, &funnel, sizeof(funnelType));
std::sort(&(copiedFunnel.val[0]), &(copiedFunnel.val[0]) + nFounders);
if(std::unique(&(copiedFunnel.val[0]), &(copiedFunnel.val[0]) + nFounders) != &(copiedFunnel.val[0]) + nFounders)
{
//If we have intercrossing generations then having repeated founders is an error. Otherwise if warnImproperFunnels is true it's still a warning.
if(intercrossingGenerations[finalCounter] != 0 || warnImproperFunnels)
{
std::stringstream ss;
ss << "Funnel for line " << pedigreeLineNames(*i) << " contained founders {" << funnel.val[0];
if(nFounders == 2)
{
ss << ", " << funnel.val[1] << "}";
}
else if(nFounders == 4)
{
ss << ", " << funnel.val[1] << ", " << funnel.val[2] << ", " << funnel.val[3] << "}";
}
else if(nFounders == 8)
{
ss << ", " << funnel.val[1] << ", " << funnel.val[2] << ", " << funnel.val[3] << ", " << funnel.val[4] << ", " << funnel.val[5] << ", " << funnel.val[6] << ", " << funnel.val[7]<< "}";
}
else if (nFounders == 16)
{
ss << ", " << funnel.val[1] << ", " << funnel.val[2] << ", " << funnel.val[3] << ", " << funnel.val[4] << ", " << funnel.val[5] << ", " << funnel.val[6] << ", " << funnel.val[7] << ", " << funnel.val[8] << ", " << funnel.val[9] << ", " << funnel.val[10] << ", " << funnel.val[11] << ", " << funnel.val[12] << ", " << funnel.val[13] << ", " << funnel.val[14] << ", " << funnel.val[15] << "}";
}
//In this case it's an error
if(intercrossingGenerations[finalCounter] != 0)
{
ss << ". Repeated founders are only allowed with zero generations of intercrossing";
errors.push_back(ss.str());
}
//But if we have zero intercrossing generations then it's only a warning
else
{
ss << ". Did you intend to use all " << nFounders << " founders?";
warnings.push_back(ss.str());
}
}
}
allFunnels.push_back(funnel);
}
//remove duplicates in representedFounders
std::sort(representedFounders.begin(), representedFounders.end());
representedFounders.erase(std::unique(representedFounders.begin(), representedFounders.end()), representedFounders.end());
//Try and check for inconsistent generations of selfing
for(std::vector<int>::iterator i = representedFounders.begin(); i != representedFounders.end(); i++)
{
if(*i > nFounders)
{
std::stringstream ss;
ss << "Error in pedigree for line number " << finalCounter << " named " << finalNames(finalCounter) << ". Inconsistent number of generations of intercrossing";
errors.push_back(ss.str());
goto nextLine;
}
}
//Not having all the founders in the input funnels is more serious if it causes the observed marker data to be impossible. So check for this.
for(int markerCounter = 0; markerCounter < nMarkers; markerCounter++)
{
bool okMarker = false;
//If observed value is an NA then than's ok, continue
int value = finals(finalCounter, markerCounter);
if(value == NA_INTEGER) continue;
for(std::vector<int>::iterator founderIterator1 = representedFounders.begin(); founderIterator1 != representedFounders.end(); founderIterator1++)
{
for(std::vector<int>::iterator founderIterator2 = representedFounders.begin(); founderIterator2 != representedFounders.end(); founderIterator2++)
{
//Note that founderIterator comes from representedFounders, which comes from getFunnel - Which returns values starting at 1, not 0. So we have to subtract one.
if(finals(finalCounter, markerCounter) == foundersToMarkerAlleles((*founderIterator1)-1, (*founderIterator2)-1, markerCounter))
{
okMarker = true;
break;
}
}
}
if(!okMarker)
{
std::stringstream ss;
ss << "Data for marker " << markerNames(markerCounter) << " is impossible for individual " << finalNames(finalCounter) << " with given pedigree";
errors.push_back(ss.str());
if(errors.size() > 1000) return;
goto nextLine;
}
}
//In this case individualsToCheckFunnels contains one element => getFunnel was only called once => we can reuse the funnel variable
if(intercrossingGenerations[finalCounter] == 0)
{
orderFunnel(&(funnel.val[0]), nFounders);
lineFunnels.push_back(funnel);
}
else
{
//Add a dummy value in lineFunnel
for(int i = 0; i < 16; i++) funnel.val[i] = 0;
lineFunnels.push_back(funnel);
}
nextLine:
;
}
}
void parse_gb_location(
Rcpp::S4 &location,
std::string &span,
std::string &accession )
{
// clean up possible whitespace
span.erase(remove_if(begin(span), end(span), ::isspace), end(span));
// initialise a BaseSpan
BaseSpan bs;
// initialise match results
std::smatch m;
// iterator over span
std::string::const_iterator first = span.begin();
std::string::const_iterator last = span.end();
// test for a possibly complemented simple location
try {
if (std::regex_match(first, last, m, PCSL)) {
parse_simple_span(bs, span, accession);
// fill gbLocation@range
// guarantied integer Matrix/two columns
IntegerMatrix range(1,2);
range(0,0) = bs.range[0];
range(0,1) = bs.range[1];
location.slot("range") = range;
// fill gbLocation@fuzzy
// guarantied logical Matrix/two columns
LogicalMatrix fuzzy(1,2);
fuzzy(0,0) = bs.fuzzy[0];
fuzzy(0,1) = bs.fuzzy[1];
location.slot("fuzzy") = fuzzy;
location.slot("strand") = bs.strand;
location.slot("accession") = bs.accession;
location.slot("remote") = bs.remote;
location.slot("type") = bs.type;
// test for a possibly complemented compound location
} else if (std::regex_match(first, last, m, PCCL)) {
// test for complementary strand
int strand(1);
if (std::regex_search(first, last, m, COMPL)) {
strand = -1;
}
// get compound span
std::regex_search(first, last, m, CL);
first = m[0].first;
last = m[0].second;
// get compound type
std::regex_search(first, last, m, CMPND);
std::string compound( m[0] );
// get span strings
std::regex_search(first, last, m, SLC);
std::string span_str( m[0] );
std::vector<std::string > spans;
std::sregex_token_iterator
first_it{begin(span_str), end(span_str), COMMA, -1},
last_it;
std::copy(first_it, last_it, std::back_inserter(spans));
int nrows = spans.size();
Rcpp::IntegerMatrix rangeMat( nrows, 2 );
Rcpp::LogicalMatrix fuzzyMat( nrows, 2 );
Rcpp::IntegerVector strandVec(nrows);
Rcpp::CharacterVector accessionVec(nrows);
Rcpp::LogicalVector remoteVec(nrows);
Rcpp::CharacterVector typeVec(nrows);
for (int i = 0; i < nrows; ++i) {
std::string span = spans[i];
parse_simple_span(bs, span, accession);
// get positions
rangeMat(i, 0) = bs.range[0];
rangeMat(i, 1) = bs.range[1];
// get fuzzy
fuzzyMat(i, 0) = bs.fuzzy[0];
fuzzyMat(i, 1) = bs.fuzzy[1];
// get strand, accession, remote and type
strandVec[i] = bs.strand;
accessionVec[i] = bs.accession;
remoteVec[i] = bs.remote;
typeVec[i] = bs.type;
}
// if the whole span is complementary reset strandVec
if (strand == -1) {
for (int i = 0; i < nrows; ++i)
strandVec[i] = -1;
}
location.slot("range") = rangeMat;
location.slot("fuzzy") = fuzzyMat;
location.slot("strand") = strandVec;
location.slot("compound") = compound;
location.slot("accession") = accessionVec;
location.slot("remote") = remoteVec;
location.slot("type") = typeVec;
} else {
throw std::range_error("Cannot parse location descriptor.");
}
} catch (std::exception &ex) {
forward_exception_to_r(ex);
}
}