void NormalVarianceMixtureBaseError::initFromList(Rcpp::List const &init_list)
{
if(init_list.containsElementNamed("sigma"))
sigma = Rcpp::as < double >( init_list["sigma"]);
else
sigma = 1.;
npars += 1;
if(init_list.containsElementNamed("common_V"))
common_V = Rcpp::as < int >( init_list["common_V"]);
else
common_V = 0;
int i = 0;
if( init_list.containsElementNamed("Vs" )){
Rcpp::List Vs_list = init_list["Vs"];
Vs.resize(Vs_list.length());
for( Rcpp::List::iterator it = Vs_list.begin(); it != Vs_list.end(); ++it ) {
Vs[i++] = Rcpp::as < Eigen::VectorXd >( it[0]);
}
}else
throw("in NormalVarianceMixtureBaseError::initFromList Vs must be set! \n");
}
void IGMeasurementError::initFromList(Rcpp::List const &init_list)
{
NormalVarianceMixtureBaseError::initFromList(init_list);
if(init_list.containsElementNamed("nu"))
nu = Rcpp::as < double >( init_list["nu"]);
else
nu = 1.;
EV = 1.; // not true it is the mode is alpha/(alpha - 1)
EiV = 1.;
npars += 1;
digamma_nu = Digamma(nu);
trigamma_nu = Trigamma(nu);
int i = 0;
if( init_list.containsElementNamed("Vs" )){
Rcpp::List Vs_list = init_list["Vs"];
Vs.resize(Vs_list.length());
for( Rcpp::List::iterator it = Vs_list.begin(); it != Vs_list.end(); ++it ) {
Vs[i++] = Rcpp::as < Eigen::VectorXd >( it[0]);
}
}else
throw("in IGMeasurementError::initFromList Vs must be set! \n");
}
void RSim::setTimeSeries(SEXP v, const string &obj_name) {
Ptr<SerializableBase> ts;
if(Rf_isMatrix(v)) {
Rcpp::List tsl;
tsl["values"] = v;
tsl.attr("class") = "TimeSeries";
ts = RProto::convertFromR<SerializableBase>(tsl);
} else {
try {
ts = RProto::convertFromR<SerializableBase>(v);
} catch(...) {
ERR("Expecting matrix with values or TimeSeries list object\n");
}
}
auto slice = Factory::inst().getObjectsSlice(obj_name);
for(auto it=slice.first; it != slice.second; ++it) {
Factory::inst().getObject(it)->setAsInput(
ts
);
}
net->spikesList().info = ts.as<TimeSeries>()->info;
for(auto &n: neurons) {
n.ref().initInternal();
}
}
void ScoreGaussL0PenScatter::setData(Rcpp::List& data)
{
std::vector<int>::iterator vi;
//uint i;
// Cast preprocessed data from R list
dout.level(2) << "Casting preprocessed data...\n";
_dataCount = Rcpp::as<std::vector<int> >(data["data.count"]);
dout.level(3) << "# samples per vertex: " << _dataCount << "\n";
_totalDataCount = Rcpp::as<uint>(data["total.data.count"]);
dout.level(3) << "Total # samples: " << _totalDataCount << "\n";
Rcpp::List scatter = data["scatter"];
Rcpp::NumericMatrix scatterMat;
_disjointScatterMatrices.resize(scatter.size());
dout.level(3) << "# disjoint scatter matrices: " << scatter.size() << "\n";
for (R_len_t i = 0; i < scatter.size(); ++i) {
scatterMat = Rcpp::NumericMatrix((SEXP)(scatter[i]));
_disjointScatterMatrices[i] = arma::mat(scatterMat.begin(), scatterMat.nrow(), scatterMat.ncol(), false);
}
// Cast index of scatter matrices, adjust R indexing convention to C++
std::vector<int> scatterIndex = Rcpp::as<std::vector<int> >(data["scatter.index"]);
for (std::size_t i = 0; i < scatterIndex.size(); ++i)
_scatterMatrices[i] = &(_disjointScatterMatrices[scatterIndex[i] - 1]);
// Cast lambda: penalty constant
_lambda = Rcpp::as<double>(data["lambda"]);
dout.level(3) << "Penalty parameter lambda: " << _lambda << "\n";
// Check whether an intercept should be calculated
_allowIntercept = Rcpp::as<bool>(data["intercept"]);
dout.level(3) << "Include intercept: " << _allowIntercept << "\n";
}
SEXP stack_trace__impl( const char *file, int line) {
const size_t max_depth = 100;
size_t stack_depth;
void *stack_addrs[max_depth];
char **stack_strings;
stack_depth = backtrace(stack_addrs, max_depth);
stack_strings = backtrace_symbols(stack_addrs, stack_depth);
std::string current_line ;
Rcpp::CharacterVector res( stack_depth - 1) ;
std::transform(
stack_strings + 1, stack_strings + stack_depth,
res.begin(),
demangler_one
) ;
free(stack_strings); // malloc()ed by backtrace_symbols
Rcpp::List trace = Rcpp::List::create(
Rcpp::Named( "file" ) = file,
Rcpp::Named( "line" ) = line,
Rcpp::Named( "stack" ) = res ) ;
trace.attr("class") = "Rcpp_stack_trace" ;
return trace ;
}
Rcpp::List MetaData::save () const
/*
* Save meta data into R list.
*
* Format:
* [[0]] ---- Number of variables
* [[1]] ---- Index of target variable
* [[2]] ---- Target variable name
* [[3]] ---- Variable name vector
* [[4]] ---- Variable type vector
* [[5]] ---- Discrete variable value list
*/
{
Rcpp::List meta_data;
meta_data[NVARS] = Rcpp::wrap(nvars_);
meta_data[VAR_NAMES] = Rcpp::wrap(var_names_);
meta_data[VAR_TYPES] = Rcpp::wrap(var_types_);
Rcpp::List valuenames;
for (val_name_map::const_iterator iter = val_names_.begin(); iter != val_names_.end(); ++iter) {
Rcpp::List vn;
vn.push_back(iter->first);
vn.push_back(iter->second);
valuenames.push_back(vn);
}
meta_data[VAL_NAMES] = Rcpp::wrap(valuenames);
return meta_data;
}
// [[Rcpp::export]]
Rcpp::List mlist2clist(Rcpp::List mlist, int nthreads=1){
if (mlist.length()==0) Rcpp::stop("empty list is invalid");
int ncounts, nmarks, nbins = -1;
std::vector<std::string> foo;
listcubedim(mlist, &nbins, &ncounts, &nmarks, foo);
Rcpp::List newdnames(2); newdnames[0] = mlist.attr("names");
//allocate storage
Rcpp::List clist(ncounts);
for (int c = 0; c < ncounts; ++c){
Rcpp::IntegerMatrix mat(nmarks, nbins);
if (!Rf_isNull(newdnames[0])) mat.attr("dimnames") = newdnames;
clist[c] = mat;
}
//copy data
#pragma omp parallel for num_threads(nthreads) collapse(2)
for (int c = 0; c < ncounts; ++c){
for (int mark = 0; mark < nmarks; ++mark){
Vec<int> col = Mat<int>((SEXP)mlist[mark]).getCol(c);
MatRow<int> row = Mat<int>((SEXP)clist[c]).getRow(mark);
for (int bin = 0; bin < nbins; ++bin){
row[bin] = col[bin];
}
}
}
return clist;
}
std::vector<OGRGeometry *> ogr_from_sfc(Rcpp::List sfc, OGRSpatialReference **sref) {
Rcpp::List wkblst = CPL_write_wkb(sfc, false);
std::vector<OGRGeometry *> g(sfc.length());
OGRSpatialReference *local_srs = NULL;
Rcpp::List crs = sfc.attr("crs");
Rcpp::IntegerVector epsg(1);
epsg[0] = crs["epsg"];
Rcpp::String p4s = crs["proj4string"];
if (p4s != NA_STRING) {
Rcpp::CharacterVector cv = crs["proj4string"];
local_srs = new OGRSpatialReference;
OGRErr err = local_srs->importFromProj4(cv[0]);
if (err != 0) {
local_srs->Release(); // #nocov
handle_error(err); // #nocov
}
}
for (int i = 0; i < wkblst.length(); i++) {
Rcpp::RawVector r = wkblst[i];
OGRErr err = OGRGeometryFactory::createFromWkb(&(r[0]), local_srs, &(g[i]),
r.length(), wkbVariantIso);
if (err != 0) {
if (local_srs != NULL) // #nocov
local_srs->Release(); // #nocov
handle_error(err); // #nocov
}
}
if (sref != NULL)
*sref = local_srs; // return and release later, or
else if (local_srs != NULL)
local_srs->Release(); // release now
return g;
}
void RSim::setInputSpikes(const Rcpp::List &l, const string &obj_name) {
Ptr<SerializableBase> sp_l;
if(l.containsElementNamed("values")) {
sp_l = RProto::convertFromR<SerializableBase>(l);
} else {
try {
Rcpp::List sl;
sl["values"] = l;
sl.attr("class") = "SpikesList";
sp_l = RProto::convertFromR<SerializableBase>(sl);
} catch (...) {
ERR("Expecting list with spike times of neurons or SpikesList list object\n");
}
}
auto slice = Factory::inst().getObjectsSlice(obj_name);
for(auto it=slice.first; it != slice.second; ++it) {
Factory::inst().getObject(it)->setAsInput(
sp_l
);
}
net->spikesList().info = sp_l.as<SpikesList>()->info;
for(auto &n: neurons) {
n.ref().initInternal();
}
}
SEXP getKernelWorkGroupInfo(SEXP sKernel, SEXP sDeviceID){
resetError("ROpenCL::getKernelWorkGroupInfo");
Rcpp::XPtr<cl_kernel> kernel(sKernel);
Rcpp::XPtr<cl_device_id> deviceID(sDeviceID);
size_t sval;
size_t sizes[3];
cl_ulong ulval;
Rcpp::List result;
#ifdef CL_KERNEL_WORK_GROUP_SIZE /* size_t */
sval = 0;
if (!logError( clGetKernelWorkGroupInfo(*kernel, *deviceID, CL_KERNEL_WORK_GROUP_SIZE, sizeof(sval), &sval, NULL) )) {
result["CL_KERNEL_WORK_GROUP_SIZE"] = Rcpp::wrap(sval);
}
#endif
#ifdef CL_KERNEL_COMPILE_WORK_GROUP_SIZE /* 3x size_t */
sizes[0] = sizes[1] = sizes[2] = 0;
if (!logError( clGetKernelWorkGroupInfo(*kernel, *deviceID, CL_KERNEL_COMPILE_WORK_GROUP_SIZE, 3*sizeof(size_t), &sizes, NULL) )) {
Rcpp::List wgs;
wgs.push_back(Rcpp::wrap(sizes[0]));
wgs.push_back(Rcpp::wrap(sizes[1]));
wgs.push_back(Rcpp::wrap(sizes[2]));
result["CL_KERNEL_COMPILE_WORK_GROUP_SIZE"] = Rcpp::wrap(wgs);
}
#endif
#ifdef CL_KERNEL_LOCAL_MEM_SIZE /* ulong */
ulval = 0;
if (!logError( clGetKernelWorkGroupInfo(*kernel, *deviceID, CL_KERNEL_LOCAL_MEM_SIZE, sizeof(ulval), &ulval, NULL) )) {
result["CL_KERNEL_LOCAL_MEM_SIZE"] = Rcpp::wrap(ulval);
}
#endif
#ifdef CL_KERNEL_PREFERRED_WORK_GROUP_SIZE_MULTIPLE /* size_t */
sval = 0;
if (!logError( clGetKernelWorkGroupInfo(*kernel, *deviceID, CL_KERNEL_PREFERRED_WORK_GROUP_SIZE_MULTIPLE, sizeof(sval), &sval, NULL) )) {
result["CL_KERNEL_PREFERRED_WORK_GROUP_SIZE_MULTIPLE"] = Rcpp::wrap(sval);
}
#endif
#ifdef CL_KERNEL_PRIVATE_MEM_SIZE /* ulong */
ulval = 0;
if (!logError( clGetKernelWorkGroupInfo(*kernel, *deviceID, CL_KERNEL_PRIVATE_MEM_SIZE, sizeof(ulval), &ulval, NULL) )) {
result["CL_KERNEL_PRIVATE_MEM_SIZE"] = Rcpp::wrap(ulval);
}
#endif
//#ifdef CL_KERNEL_GLOBAL_WORK_SIZE /* 3x size_t */ TODO FIX THIS
/*
sizes[0] = sizes[1] = sizes[2] = 0;
if (!logError( clGetKernelWorkGroupInfo(*kernel, *deviceID, CL_KERNEL_GLOBAL_WORK_SIZE, 3*sizeof(size_t), &sizes, NULL) )) {
Rcpp::List gws;
gws.push_back(Rcpp::wrap(sizes[0]));
gws.push_back(Rcpp::wrap(sizes[1]));
gws.push_back(Rcpp::wrap(sizes[2]));
result["CL_KERNEL_GLOBAL_WORK_SIZE"] = Rcpp::wrap(gws);
}
*/
//#endif
PRINTONERROR();
return result;
}
Rcpp::List jaspResults::getKeepList()
{
Rcpp::List keep = getPlotPathsForKeep();
keep.push_front(std::string(_saveResultsHere));
keep.push_front(_relativePathKeep);
return keep;
}
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
}
// Simpler version for Windows and *BSD
SEXP stack_trace__impl( const char* file, int line ){
Rcpp::List trace = Rcpp::List::create(
Rcpp::Named( "file" ) = file,
Rcpp::Named( "line" ) = line,
Rcpp::Named( "stack" ) = "C++ stack not available on this system"
) ;
trace.attr("class") = "Rcpp_stack_trace" ;
return trace ;
}
std::vector<GEOSGeom> geometries_from_sfc(GEOSContextHandle_t hGEOSCtxt, Rcpp::List sfc) {
double precision = sfc.attr("precision");
Rcpp::List wkblst = CPL_write_wkb(sfc, false, native_endian(), "XY", precision);
std::vector<GEOSGeom> g(sfc.size());
for (int i = 0; i < sfc.size(); i++) {
Rcpp::RawVector r = wkblst[i];
g[i] = GEOSGeomFromWKB_buf_r(hGEOSCtxt, &(r[0]), r.size());
}
return g;
}
static Rcpp::List getDeviceFPConfigAsList(cl_device_fp_config flags)
{
Rcpp::List list;
#ifdef CL_FP_DENORM
if (flags & CL_FP_DENORM) list.push_back(Rcpp::wrap("CL_FP_DENORM"));
#endif
#ifdef CL_FP_INF_NAN
if (flags & CL_FP_INF_NAN) list.push_back(Rcpp::wrap("CL_FP_INF_NAN"));
#endif
#ifdef CL_FP_ROUND_TO_NEAREST
if (flags & CL_FP_ROUND_TO_NEAREST) list.push_back(Rcpp::wrap("CL_FP_ROUND_TO_NEAREST"));
#endif
#ifdef CL_FP_ROUND_TO_ZERO
if (flags & CL_FP_ROUND_TO_ZERO) list.push_back(Rcpp::wrap("CL_FP_ROUND_TO_ZERO"));
#endif
#ifdef CL_FP_ROUND_TO_INF
if (flags & CL_FP_ROUND_TO_INF) list.push_back(Rcpp::wrap("CL_FP_ROUND_TO_INF"));
#endif
#ifdef CL_FP_FMA
if (flags & CL_FP_FMA) list.push_back(Rcpp::wrap("CL_FP_FMA"));
#endif
#ifdef CL_FP_SOFT_FLOAT
if (flags & CL_FP_SOFT_FLOAT) list.push_back(Rcpp::wrap("CL_FP_SOFT_FLOAT"));
#endif
#ifdef CL_FP_CORRECTLY_ROUNDED_DIVIDE_SQRT
if (flags & CL_FP_CORRECTLY_ROUNDED_DIVIDE_SQRT) list.push_back(Rcpp::wrap("CL_FP_CORRECTLY_ROUNDED_DIVIDE_SQRT"));
#endif
return list;
}
//' rcpp_neutral_hotspots
//'
//' Implements neutral model in two dimensions
//'
//' @param nbs An \code{spdep} \code{nb} object listing all neighbours of each
//' point.
//' @param wts Weighting factors for each neighbour; must have same length as
//' nbs.
//' @param nbsi List of matrices as returned from \code{get_nbsi}. each element
//' of which contains the i-th nearest neighbour to each point.
//' @param alpha Strength of spatial autocorrelation
//' @param sd0 Standard deviation of truncated normal distribution used to model
//' environmental variation (with mean of 1)
//' @param log_scale If TRUE, raw hotspot values are log-transformed
//' @param niters Number of iterations of spatial autocorrelation
//' @param ac_type Character string specifying type of aucorrelation
//' (\code{moran}, \code{geary}, or code{getis-ord}).
//'
//' @return A vector of simulated values of same size as \code{nbs}.
//'
// [[Rcpp::export]]
Rcpp::NumericMatrix rcpp_neutral_hotspots (Rcpp::List nbs, Rcpp::List wts,
Rcpp::List nbsi, double alpha, double sd0, bool log_scale, int niters,
std::string ac_type)
{
const int size = nbs.size ();
int indx;
double wtsum, tempd;
Rcpp::NumericMatrix tempmat;
Rcpp::NumericVector z1 = rcpp_trunc_ndist (size, sd0);
Rcpp::NumericVector z2 (size), nbs_to, nbs_from, nbs_n, ac;
// Spatial autocorrelation
for (int i=0; i<niters; i++)
{
std::fill (z2.begin (), z2.end (), 0.0);
for (int j=0; j<nbsi.size (); j++)
{
tempmat = Rcpp::as <Rcpp::NumericMatrix> (nbsi (j));
nbs_to = tempmat (Rcpp::_, 0);
nbs_from = tempmat (Rcpp::_, 1);
nbs_n = tempmat (Rcpp::_, 2);
// Note that nbs are 1-indexed
for (int k=0; k<nbs_to.size (); k++)
{
z2 (nbs_to (k) - 1) += ((1.0 - alpha) * z1 (nbs_to (k) - 1) +
alpha * z1 (nbs_from (k) - 1)) / (double) nbs_n (k);
}
} // end for j over nbsi
std::copy (z2.begin (), z2.end (), z1.begin ());
} // end for i over niters
if (log_scale)
{
// negative values sometimes arise for alpha < 0, but scale is
// arbitrary, so re-scaled here to ensure all values are > 0
z1 = 1.0 + z1 - (double) Rcpp::min (z1);
z1 = log10 (z1);
}
ac = rcpp_ac_stats (z1, nbs, wts, ac_type);
std::sort (z1.begin (), z1.end (), std::greater<double> ());
z1 = (z1 - (double) Rcpp::min (z1)) /
((double) Rcpp::max (z1) - (double) Rcpp::min (z1));
Rcpp::NumericMatrix result (size, 2);
result (Rcpp::_, 0) = z1;
result (Rcpp::_, 1) = ac;
Rcpp::colnames (result) = Rcpp::CharacterVector::create ("y", "ac");
return result;
}
static Rcpp::List getDeviceMemCacheTypeAsList(cl_device_mem_cache_type flags)
{
Rcpp::List list;
#ifdef CL_READ_ONLY_CACHE
if (flags & CL_READ_ONLY_CACHE) list.push_back(Rcpp::wrap("CL_READ_ONLY_CACHE"));
#endif
#ifdef CL_READ_WRITE_CACHE
if (flags & CL_READ_WRITE_CACHE) list.push_back(Rcpp::wrap("CL_READ_WRITE_CACHE"));
#endif
return list;
}
Rcpp::List Commit::parent_list()
{
BEGIN_RCPP
Rcpp::List v;
unsigned int c = parent_count();
for (int i=0; i<c; ++i) {
v.push_back(parent(i));
}
return v;
END_RCPP
}
// [[Rcpp::export]]
Rcpp::List CPL_geos_op(std::string op, Rcpp::List sfc,
double bufferDist = 0.0, int nQuadSegs = 30,
double dTolerance = 0.0, bool preserveTopology = false,
int bOnlyEdges = 1, double dfMaxLength = 0.0) {
GEOSContextHandle_t hGEOSCtxt = CPL_geos_init();
std::vector<GEOSGeom> g = geometries_from_sfc(hGEOSCtxt, sfc);
std::vector<GEOSGeom> out(sfc.length());
if (op == "buffer") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSBuffer_r(hGEOSCtxt, g[i], bufferDist, nQuadSegs));
} else if (op == "boundary") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSBoundary_r(hGEOSCtxt, g[i]));
} else if (op == "convex_hull") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSConvexHull_r(hGEOSCtxt, g[i]));
} else if (op == "union_cascaded") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSUnionCascaded_r(hGEOSCtxt, g[i]));
} else if (op == "simplify") {
for (size_t i = 0; i < g.size(); i++)
out[i] = preserveTopology ? chkNULL(GEOSTopologyPreserveSimplify_r(hGEOSCtxt, g[i], dTolerance)) :
chkNULL(GEOSSimplify_r(hGEOSCtxt, g[i], dTolerance));
} else if (op == "linemerge") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSLineMerge_r(hGEOSCtxt, g[i]));
} else if (op == "polygonize") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSPolygonize_r(hGEOSCtxt, &(g[i]), 1)); // xxx
} else if (op == "centroid") {
for (size_t i = 0; i < g.size(); i++) {
out[i] = chkNULL(GEOSGetCentroid_r(hGEOSCtxt, g[i]));
}
} else
#if GEOS_VERSION_MAJOR >= 3 && GEOS_VERSION_MINOR >= 4
if (op == "triangulate") {
for (size_t i = 0; i < g.size(); i++)
out[i] = chkNULL(GEOSDelaunayTriangulation_r(hGEOSCtxt, g[i], dTolerance, bOnlyEdges));
} else
#endif
throw std::invalid_argument("invalid operation"); // would leak g and out
for (size_t i = 0; i < g.size(); i++)
GEOSGeom_destroy_r(hGEOSCtxt, g[i]);
Rcpp::List ret(sfc_from_geometry(hGEOSCtxt, out)); // destroys out
CPL_geos_finish(hGEOSCtxt);
ret.attr("crs") = sfc.attr("crs");
return ret;
}
// [[Rcpp::export]]
Rcpp::List CPL_gdal_segmentize(Rcpp::List sfc, double dfMaxLength = 0.0) {
if (dfMaxLength <= 0.0)
throw std::invalid_argument("argument dfMaxLength should be positive\n");
std::vector<OGRGeometry *> g = ogr_from_sfc(sfc, NULL);
for (size_t i = 0; i < g.size(); i++)
g[i]->segmentize(dfMaxLength);
Rcpp::List ret = sfc_from_ogr(g, true);
ret.attr("crs") = sfc.attr("crs");
return ret;
}
void RcppSArray::from_dict_list(Rcpp::List lst) {
std::vector<flexible_type> f_vec(lst.size());
for (size_t i = 0; i < lst.size(); i++) {
Rcpp::XPtr<rcpp_dict> ptr((SEXP)lst[i]);
rcpp_dict d = *ptr.get() ;
flex_dict f_dict;
for(auto imap: d) {
f_dict.push_back(std::make_pair(imap.first, imap.second)) ;
}
f_vec[i] = f_dict;
}
sarray = gl_sarray(f_vec) ;
}
void parseDataFrame(SEXP dataFrameObj, vector<Feature>& dataMatrix, vector<string>& sampleHeaders) {
Rcpp::DataFrame df(dataFrameObj);
//Rcpp::CharacterVector colNames = df.attr("names");
//Rcpp::CharacterVector rowNames = df.attr("row.names");
vector<string> featureHeaders = df.attr("names");
vector<string> foo = df.attr("row.names");
sampleHeaders = foo;
dataMatrix.resize( 0 );
//cout << "nf = " << featureHeaders.size() << endl;
//cout << "ns = " << sampleHeaders.size() << endl;
// Read one column of information, which in this case is assumed to be one sample
for ( size_t i = 0; i < featureHeaders.size(); ++i ) {
Rcpp::List vec = df[i];
assert(vec.length() == sampleHeaders.size() );
//cout << " " << foo[0] << flush;
//cout << " df[" << i << "].length() = " << vec.length() << endl;
if ( featureHeaders[i].substr(0,2) != "N:" ) {
vector<string> sVec(sampleHeaders.size());
for ( size_t j = 0; j < sampleHeaders.size(); ++j ) {
//cout << Rcpp::as<string>(vec[j]) << endl;
sVec[j] = Rcpp::as<string>(vec[j]);
}
if ( featureHeaders[i].substr(0,2) == "T:" ) {
bool doHash = true;
dataMatrix.push_back( Feature(sVec,featureHeaders[i],doHash) );
} else {
dataMatrix.push_back( Feature(sVec,featureHeaders[i]) );
}
} else {
vector<num_t> sVec(sampleHeaders.size());
for ( size_t j = 0; j < sampleHeaders.size(); ++j ) {
sVec[j] = Rcpp::as<num_t>(vec[j]);
}
dataMatrix.push_back( Feature(sVec,featureHeaders[i]) );
}
// cout << "df[" << j << "," << i << "] = " << Rcpp::as<num_t>(vec[j]) << endl;
// }
}
assert( dataMatrix.size() == featureHeaders.size() );
}
// [[Rcpp::export]]
Rcpp::IntegerMatrix PredictBoardCombine
(
const Rcpp::IntegerMatrix& input_board,
const Rcpp::List& prob_dists_5by5,
const Rcpp::List& prob_dists_3by3,
const unsigned int delta = 1
)
{
// ::::::::NOTE::::::
// using R indexing conventions for delta
using namespace Rcpp;
const unsigned int nrow = gol_board_nrow;
const unsigned int ncol = gol_board_ncol;
// get correct distributions
Rcpp::String delta_index = "d" + Rcpp::toString(delta);
const NumericVector& prob_5by5 = prob_dists_5by5[delta_index];
const NumericVector& prob_3by3 = prob_dists_3by3[delta_index];
bool bad_list = (prob_dists_5by5.size() != 5 || prob_dists_3by3.size() !=5);
if(bad_list)
{
Rcpp::stop("[PredictBoard] prob_dist list must be size 5");
}
// prod dists for a given delta
//const Rcpp::NumericVector probs_5by5 = Rcpp::as<Rcpp::NumericVector>(prob_dists[delta-1 ]);
//const Rcpp::NumericVector probs_3by3 = Rcpp::as<Rcpp::NumericVector>(prob_dists[delta-1+num_deltas]);
Rcpp::IntegerMatrix prediction(nrow, ncol);
for( int i = 0; i < nrow; i++)
{
for( int j = 0; j < ncol; j++)
{
const unsigned int tag5 = GetTag<5>(input_board, i,j);
double prob = prob_5by5[tag5];
if( prob < 0 && prob > -.9)
{
const unsigned int tag3 = GetTag<3>(input_board, i,j);
double prob = prob_3by3[tag3];
}
prediction(i,j) = (prob > 0.5? 1 : 0);
}
}
return prediction;
}
void constMatrix::initFromList(Rcpp::List const & init_list)
{
npars = 1;
std::vector<std::string> check_names = {"Q","loc", "h"};
check_Rcpplist(init_list, check_names, "constMatrix::initFromList");
Q = Rcpp::as<Eigen::SparseMatrix<double,0,int> >(init_list["Q"]);
d = Q.rows();
int nIter = Rcpp::as<double>(init_list["nIter"]);
tauVec.resize(nIter+1);
npars = 0;
v.setZero(1);
m.resize(1,1);
tau = 1.;
if(init_list.containsElementNamed("tau"))
tau = Rcpp::as<double >( init_list["tau"]);
Q *= tau;
dtau = 0.;
ddtau = 0.;
counter = 0;
tauVec[counter] = tau;
counter++;
loc = Rcpp::as< Eigen::VectorXd >(init_list["loc"]);
h = Rcpp::as< Eigen::VectorXd >(init_list["h"]);
h_average = h.sum() / h.size();
m_loc = loc.minCoeff();
}
// [[Rcpp::export]]
Rcpp::List clist2mlist(Rcpp::List clist, int nthreads=1){
if (clist.length()==0) Rcpp::stop("empty list is invalid");
int ncounts, nmarks, nbins = -1;
std::vector<std::string> rnames;
listcubedim(clist, &nmarks, &nbins, &ncounts, rnames);
//allocate storage
Rcpp::List mlist(nmarks);
for (int mark = 0; mark < nmarks; ++mark){
mlist[mark] = Rcpp::IntegerMatrix(nbins, ncounts);
}
if (rnames.size() > 0) mlist.attr("names") = rnames;
//copy data
#pragma omp parallel for num_threads(nthreads) collapse(2)
for (int c = 0; c < ncounts; ++c){
for (int mark = 0; mark < nmarks; ++mark){
MatRow<int> row = Mat<int>((SEXP)clist[c]).getRow(mark);
Vec<int> col = Mat<int>((SEXP)mlist[mark]).getCol(c);
for (int bin = 0; bin < nbins; ++bin){
col[bin] = row[bin];
}
}
}
return mlist;
}
//' rcpp_neutral_hotspots_ntests
//'
//' Performs repeated neutral tests to yield average distributions of both
//' hotspot values and spatial autocorrelation statistics.
//'
//' @param nbs An \code{spdep} \code{nb} object listing all neighbours of each
//' point.
//' @param wts Weighting factors for each neighbour; must have same length as
//' nbs.
//' @param nbsi List of matrices as returned from \code{get_nbsi}. each element
//' of which contains the i-th nearest neighbour to each point.
//' @param alpha Strength of spatial autocorrelation
//' @param sd0 Standard deviation of truncated normal distribution used to model
//' environmental variation (with mean of 1)
//' @param nt Number of successive layers of temporal and spatial autocorrelation
//' used to generate final modelled values
//' @param ntests Number of tests used to obtain average values
//' @param ac_type Character string specifying type of aucorrelation
//' (\code{moran}, \code{geary}, or code{getis-ord}).
//'
//' @return A matrix of dimension (size, 2), with first column containing
//' sorted and re-scaled hotspot values, and second column containing sorted and
//' re-scaled spatial autocorrelation statistics.
//'
// [[Rcpp::export]]
Rcpp::NumericMatrix rcpp_neutral_hotspots_ntests (Rcpp::List nbs,
Rcpp::List wts, Rcpp::List nbsi, double alpha, double sd0, int niters,
std::string ac_type, bool log_scale, int ntests)
{
const int size = nbs.size ();
Rcpp::NumericMatrix hs1;
Rcpp::NumericVector z (size), z1 (size), ac (size), ac1 (size);
std::fill (ac.begin (), ac.end (), 0.0);
std::fill (z.begin (), z.end (), 0.0);
for (int n=0; n<ntests; n++)
{
hs1 = rcpp_neutral_hotspots (nbs, wts, nbsi, alpha, sd0, log_scale,
niters, ac_type);
z += hs1 (Rcpp::_, 0);
ac += hs1 (Rcpp::_, 1);
}
Rcpp::NumericMatrix result (size, 2);
result (Rcpp::_, 0) = z / (double) ntests;
result (Rcpp::_, 1) = ac / (double) ntests;
Rcpp::colnames (result) = Rcpp::CharacterVector::create ("z", "ac");
return result;
}
// [[Rcpp::export]]
Rcpp::List cpp_Relaxed_RIT(Rcpp::List const& datas,Rcpp::NumericVector const& theta,
Rcpp::LogicalVector const& factor,double epsilon_cont,double epsilon_cat,int n_trees,
int depth,int branch,int min_inter_sz,double radius,bool es){
unordered_map<string,Interaction> res;
// Transform types
vector<bool> cFactor = Rcpp::as<vector<bool> >(factor);
vector<double> c_theta = Rcpp::as<vector<double> >(theta);
for(int c=0;c<datas.size();++c){// Iterate over classes
Rcpp::DataFrame class_data = Rcpp::as<Rcpp::DataFrame>(datas[c]);
Generator gen = create_PRNG(class_data);
for(int t=0;t<n_trees;++t){// Iterate over n_trees
//Rcpp::Rcout << "Tree " << t << " of class " << c << endl;
tree(res,datas,c,c_theta,cFactor,epsilon_cont,epsilon_cat,depth,min_inter_sz,branch,gen,radius,es);
Rcpp::checkUserInterrupt();
}
}
// Transform to R type
Rcpp::List ret(res.size());
Rcpp::CharacterVector keys(res.size());
int i = 0;
for(auto& kv : res){
keys[i] = kv.first;
ret[i] = kv.second.as_List(datas);
i++;
}
ret.names() = keys;
return ret;
}
SEXP getPlatformInfo(SEXP sPlatformID){
resetError("ROpenCL::getPlatformInfo");
static char cBuffer[1024];
Rcpp::XPtr<cl_platform_id> platformID(sPlatformID);
std::string str;
Rcpp::List result;
#ifdef CL_PLATFORM_PROFILE /* TODO CHECK THIS IS STRING RETURN VALUE */
cBuffer[0] = '\0';
logError( clGetPlatformInfo(*platformID, CL_PLATFORM_PROFILE, sizeof(cBuffer), cBuffer, NULL) );
str = cBuffer;
result["CL_PLATFORM_PROFILE"] = Rcpp::wrap(str);
#endif
#ifdef CL_PLATFORM_VERSION
cBuffer[0] = '\0';
logError( clGetPlatformInfo(*platformID, CL_PLATFORM_VERSION, sizeof(cBuffer), cBuffer, NULL) );
str = cBuffer;
result["CL_PLATFORM_VERSION"] = Rcpp::wrap(str);
#endif
#ifdef CL_PLATFORM_NAME
cBuffer[0] = '\0';
logError( clGetPlatformInfo (*platformID, CL_PLATFORM_NAME, sizeof(cBuffer), cBuffer, NULL) );
str = cBuffer;
result["CL_PLATFORM_NAME"] = Rcpp::wrap(str);
#endif
#ifdef CL_PLATFORM_VENDOR
cBuffer[0] = '\0';
logError( clGetPlatformInfo(*platformID, CL_PLATFORM_VENDOR, sizeof(cBuffer), cBuffer, NULL) );
str = cBuffer;
result["CL_PLATFORM_VENDOR"] = Rcpp::wrap(str);
#endif
#ifdef CL_PLATFORM_EXTENSIONS
cBuffer[0] = '\0';
logError( clGetPlatformInfo(*platformID, CL_PLATFORM_EXTENSIONS, sizeof(cBuffer), cBuffer, NULL) );
str = cBuffer;
std::string word;
std::stringstream ss(str); // Insert the string into a stream
Rcpp::List extensions;
while (ss >> word) { // Fetch next word from stream
extensions.push_back(Rcpp::wrap(word));
}
result["CL_PLATFORM_EXTENSIONS"] = Rcpp::wrap(extensions);
#endif
PRINTONERROR();
return result;
}
Rcpp::List sfc_from_ogr(std::vector<OGRGeometry *> g, bool destroy = false) {
Rcpp::List lst(g.size());
Rcpp::List crs = get_crs(g.size() && g[0] != NULL ? g[0]->getSpatialReference() : NULL);
for (size_t i = 0; i < g.size(); i++) {
if (g[i] == NULL)
Rcpp::stop("NULL error in sfc_from_ogr"); // #nocov
Rcpp::RawVector raw(g[i]->WkbSize());
handle_error(g[i]->exportToWkb(wkbNDR, &(raw[0]), wkbVariantIso));
lst[i] = raw;
if (destroy)
OGRGeometryFactory::destroyGeometry(g[i]);
}
Rcpp::List ret = CPL_read_wkb(lst, false, false);
ret.attr("crs") = crs;
ret.attr("class") = "sfc";
return ret;
}
//[[Rcpp::export]]
SEXP CPP_seg(Rcpp::List data, Rcpp::List dataC, int minReadsRegion, int minLregion, int minReads, int step, int width, int maxStep, int minDist, int verbose){
//minReadsRegion : The min number of reads for a region to be kept as candidate
//minLregion : The min size of a region
//minReads : The min number of reads for a window to be included in a region
//step : The step for the sliding window
//width : Half the length of the sliding window
//maxStep : Used in callRegionsL
//minDist : in PING, when reads are too close to the center of the windows, they are not counted in the window score
//verbose : Print debug values
if(verbose>1){
cout<<"step = "<<step<<endl;
cout<<"maxStep = "<<maxStep<<endl;
cout<<"width = "<<width<<endl;
cout<<"minReads = "<<minReads<<endl;
cout<<"minLregion = "<<minLregion<<endl;
}
string chr;
vector<string> chrs = data.names();
Rcpp::List ret(data.size());
for(int i=0; i < data.size(); i++){
chr = chrs[i];
if(verbose>1){
cout<<"Processing chromosome "<<chr<<endl;
}
//access sub list
Rcpp::List dataList = data[chr];
Rcpp::List contList = dataC[chr];
//R to c++ vectors
std::vector<int> yF = Rcpp::as<std::vector<int> >(dataList["F"]);
std::vector<int> yR = Rcpp::as<std::vector<int> >(dataList["R"]);
std::vector<int> contF = Rcpp::as<std::vector<int> >(contList["F"]);
std::vector<int> contR = Rcpp::as<std::vector<int> >(contList["R"]);
ret[i] = seg_chr(yF, yR, contF, contR, minReadsRegion, minLregion, minReads, step, width, maxStep, minDist, verbose);
}
for(int j=0; j<data.size(); j++){
}
Rcpp::Language new_segReadsList("new", "segReadsList");
Rcpp::S4 returnVal(new_segReadsList.eval());
returnVal.slot("List") = ret;
return(returnVal);
}
