C++ rcpp::List类代码示例

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
}

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;
}