// [[Rcpp::export]]
NumericVector computeAllLogLkhd(
NumericVector observedCases, NumericVector expectedCases,
List nearestNeighborsList, int nZones, String logLkhdType) {
NumericVector allLogLkhd(nZones);
int nAreas = expectedCases.size(), C = sum(observedCases),
N = sum(expectedCases), index = 0;
int nNeighbors = 0;
double cz = 0.0, nz = 0.0;
for (int i = 0; i < nAreas; ++i) {
cz = 0;
nz = 0;
Rcpp::NumericVector nearestNeighbors = nearestNeighborsList[i];
nNeighbors = nearestNeighbors.size();
// For each area's nearest neighbors
for(int j = 0; j < nNeighbors; ++j) {
// Watch off by 1 vector indexing in C as opposed to R
cz += observedCases[nearestNeighbors[j]-1];
nz += expectedCases[nearestNeighbors[j]-1];
if (logLkhdType=="poisson") {
allLogLkhd[index] = poissonLogLkhd(cz, nz, N, C);
} else if (logLkhdType == "binomial" ) {
allLogLkhd[index] = binomialLogLkhd(cz, nz, N, C);
}
index++;
}
}
return allLogLkhd;
}
static void print(Rcpp::NumericVector a)
{
for (int i = 0; i < a.size(); i++) {
printf("%f ", a[i]);
}
putchar('\n');
}
double Util::innerProduct(Rcpp::NumericVector x,
Rcpp::NumericVector y) {
double erg=0;
for(int i = 0;i<x.size();i++){
erg = erg+ (x[i]*y[i]);
}
return erg;
}
// [[Rcpp::export]]
double trapzRcpp(const Rcpp::NumericVector X, const Rcpp::NumericVector Y){
if( Y.size() != X.size()){
Rcpp::stop("The input Y-grid does not have the same number of points as input X-grid.");
}
if(is_sorted(X.begin(),X.end())){
double trapzsum = 0;
for (unsigned int ind = 0; ind != X.size()-1; ++ind){
trapzsum += 0.5 * (X[ind + 1] - X[ind]) *(Y[ind] + Y[ind + 1]);
}
return trapzsum;
} else {
Rcpp::stop("The input X-grid is not sorted.");
return std::numeric_limits<double>::quiet_NaN();
}
return std::numeric_limits<double>::quiet_NaN();
}
//' @rdname MultivariateSpecial
//' @return \code{lgammap} is the log multivariate gamma function.
//' @note For \code{lgammp}, warnings of the type \code{"value out of range in
//' 'lgamma'"} is due to evaluation in the half integers below \eqn{(p-1)/2}.
//' @export
// [[Rcpp::export]]
Rcpp::NumericVector lgammap(const Rcpp::NumericVector & x, const int p = 1) {
const double c0 = log(M_PI)*p*(p - 1)/4;
Rcpp::NumericVector ans(x.size(), c0);
for (int j = 0; j < p; ++j) {
ans += Rcpp::lgamma(x - j/2.0f);
}
return ans;
}
// Calculate picewise constant baseline cumulative hazard function at t=(t_1, ..., t_n)
// where h=(h0, h1, ..., hM) with h0=0 and d=(d0, d1, ..., dM) with d0=0, dM=R_PosInf
arma::vec Lambda0tvec(Rcpp::NumericVector t, Rcpp::NumericVector h, Rcpp::NumericVector d){
int n = t.size();
arma::vec res(n);
for (int i=0; i<n; ++i){
res[i] = Lambda0t(t[i],h,d);
}
return(res);
}
// [[Rcpp::export]]
double rcpp_sumv(Rcpp::NumericVector A)
{ int na= A.size();
double b=0;
for (int i = 0; i < na; i++)
{ b=b+A(i);
}
return b;
}
// kernel Dist function on a Grid
// [[Rcpp::export]]
Rcpp::NumericVector
KdeDist(const Rcpp::NumericMatrix & X
, const Rcpp::NumericMatrix & Grid
, const double h
, const Rcpp::NumericVector & weight
, const bool printProgress
) {
const unsigned sampleNum = X.nrow();
const unsigned dimension = Grid.ncol();
const unsigned gridNum = Grid.nrow();
// first = sum K_h(X_i, X_j), second = K_h(x, x), third = sum K_h(x, X_i)
std::vector< double > firstValue;
const double second = 1.0;
std::vector< double > thirdValue;
double firstmean;
Rcpp::NumericVector kdeDistValue(gridNum);
int counter = 0, percentageFloor = 0;
int totalCount = sampleNum + gridNum;
if (printProgress) {
printProgressFrame(Rprintf);
}
firstValue = computeKernel< std::vector< double > >(
X, X, h, weight, printProgress, Rprintf, counter, totalCount,
percentageFloor);
if (dimension <= 1) {
thirdValue = computeKernel< std::vector< double > >(
X, Grid, h, weight, printProgress, Rprintf, counter, totalCount,
percentageFloor);
}
else {
thirdValue = computeGaussOuter< std::vector< double > >(
X, Grid, h, weight, printProgress, Rprintf, counter, totalCount,
percentageFloor);
}
if (weight.size() == 1) {
firstmean = std::accumulate(firstValue.begin(), firstValue.end(), 0.0) / sampleNum;
}
else {
firstmean = std::inner_product(
firstValue.begin(), firstValue.end(), weight.begin(), 0.0) /
std::accumulate(weight.begin(), weight.end(), 0.0);
}
for (unsigned gridIdx = 0; gridIdx < gridNum; ++gridIdx) {
kdeDistValue[gridIdx] = std::sqrt(firstmean + second - 2 * thirdValue[gridIdx]);
}
if (printProgress) {
Rprintf("\n");
}
return kdeDistValue;
}
reModule::reModule(Rcpp::S4 Zt, Rcpp::S4 Lambda, Rcpp::S4 L,
Rcpp::IntegerVector Lind, Rcpp::NumericVector lower)
throw (MatrixNs::wrongS4)
: d_L(L), d_Lambda(Lambda), d_Zt(Zt), d_Lind(Lind),
d_lower(lower), d_theta(lower.size()),
d_u0(d_Lambda.nr(), 0.), d_incr(d_Lambda.nr()),
d_u(d_Lambda.nr()),d_cu(d_Lambda.nr()) {
d_Ut = (CHM_SP)NULL;
}
// redis "set a vector" -- without R serialization, without attributes, ...
// this is somewhat experimental
std::string setVector(std::string key, Rcpp::NumericVector x) {
redisReply *reply =
static_cast<redisReply*>(redisCommand(prc_, "SET %s %b",
key.c_str(), x.begin(), x.size()*szdb));
std::string res(reply->str);
freeReplyObject(reply);
return(res);
}
//' @export
//' @rdname logit
// [[Rcpp::export]]
Rcpp::NumericVector invlogit(Rcpp::NumericVector x) {
int n = x.size();
Rcpp::NumericVector result(n);
for (int i=0; i < n; ++i) {
result[i] = 1.0 / (1.0 + exp (-1.0 * x[i]));
}
return result;
}
//' @title logit and inverse logit functions
//'
//' @description
//' transform \code{x} either via the logit, or inverse logit.
//'
//' @details
//' The loogit and inverse logit functions are part of R via the
//' logistic distribution functions in the stats package.
//' Quoting from the documentation for the logistic distribution
//'
//' "\code{qlogis(p)} is the same as the \code{logit} function, \code{logit(p) =
//' log(p/1-p)}, and \code{plogis(x)} has consequently been called the 'inverse
//' logit'."
//'
//' See the examples for benchmarking these functions. The \code{logit} and
//' \code{invlogit} functions are faster than the \code{qlogis} and \code{plogis}
//' functions.
//'
//' @seealso \code{\link[stats]{qlogis}}
//'
//' @examples
//' library(qwraps2)
//' library(rbenchmark)
//'
//' # compare logit to qlogis
//' p <- runif(1e5)
//' identical(logit(p), qlogis(p))
//' benchmark(logit(p), qlogis(p))
//'
//' # compare invlogit to plogis
//' x <- runif(1e5, -1000, 1000)
//' identical(invlogit(x), plogis(x))
//' benchmark(invlogit(x), plogis(x))
//'
//' @param x a numeric vector
//' @export
//' @rdname logit
// [[Rcpp::export]]
Rcpp::NumericVector logit(Rcpp::NumericVector x) {
int n = x.size();
Rcpp::NumericVector result(n);
for(int i = 0; i < n; ++i) {
result[i] = log( x[i] / (1.0 - x[i]) );
}
return result;
}
// [[Rcpp::export]]
double rcpp_sum_(Rcpp::NumericVector x)
{
double ret = 0;
#pragma omp parallel for default(shared) reduction(+:ret)
for (int i=0; i<x.size(); i++)
ret += x[i];
return ret;
}
static Rcpp::IntegerVector nz(Rcpp::NumericVector v, double eps)
{
int n = v.size();
Rcpp::IntegerVector result(n);
for(int i=0; i < n; i++){
result[i] = nz(v[i],eps);
}
return result;
}
bool isincreasing(Rcpp::NumericVector arg){
int length=arg.size();
bool res=true;
for (int n=1; n<(length); n++)
if (arg[n]<=arg[n-1]){
res=false;
break;
}
return res;
}
// Calculate M(ti), i=1, ..., n;
// where h=(h0, h1, ..., hM) with h0=0 and d=(d0, d1, ..., dM) with d0=0, dM=R_PosInf
void GetMt(Rcpp::IntegerVector& Mt, const Rcpp::NumericVector& t, Rcpp::NumericVector d){
int n = t.size();
for (int i=0; i<n; ++i){
int k = 1;
while ( (t[i]>d[k]) ){
++k;
}
Mt[i] = k;
}
}
// [[Rcpp::export]]
Rcpp::NumericVector mutateCR(Rcpp::NumericVector sol, Rcpp::NumericMatrix nn,int L, Rcpp::NumericMatrix neighborhood, Rcpp::NumericVector randomVectorMutation, NumericVector randomVectorSelection) {
Rcpp::NumericVector newsol = sol;
for(int i = 0; i<sol.size(); i++)
{
if(randomVectorMutation[i] < neighborhood(i,sol[i]-1))
{
newsol[i]=nn(i,randomVectorSelection[i]-1);
}
}
return(newsol);
}
// redis "prepend to list" -- without R serialization
// as above: pure vector, no attributes, ...
std::string listLPush(std::string key, Rcpp::NumericVector x) {
// uses binary protocol, see hiredis doc at github
redisReply *reply =
static_cast<redisReply*>(redisCommand(prc_, "LPUSH %s %b",
key.c_str(), x.begin(), x.size()*szdb));
//std::string res(reply->str);
std::string res = "";
freeReplyObject(reply);
return(res);
}
// [[Rcpp::export]]
Rcpp::NumericMatrix latlonfromcell(Rcpp::NumericVector cells, Rcpp::NumericVector extent, int nrow, int ncol)
{
float uplon = extent[0];
float uplat = extent[3];
float xres = (extent[1] - extent[0])/ncol;
float yres = (extent[3] - extent[2])/nrow;
Rcpp::NumericMatrix m(cells.size(), 2);
for(int i = 0; i < cells.size(); ++i) {
int row = ceil(cells[i] / ncol);
int col = cells[i] - ((row - 1) * ncol);
float lat = uplat - (row * yres) + (0.5 * yres);
float lon = uplon + (col * xres) - (0.5 * xres);
m(i,0) = lat;
m(i,1) = lon;
}
return m ;
}
merResp::merResp(Rcpp::NumericVector y, Rcpp::NumericVector weights)
throw (std::runtime_error)
: d_y(y), d_weights(weights), d_offset(y.size()),
d_mu(y.size()), d_sqrtrwt(y.size()), d_wtres(y.size()),
d_sqrtXwt(y.size(), 1) {
if (weights.size() != y.size())
throw std::runtime_error(
"lengths of y and wts must agree");
init();
}
SEXP conditionalPoissonSecondInclusion(SEXP sizes_sexp, SEXP n_sexp)
{
BEGIN_RCPP
Rcpp::NumericVector sizes = Rcpp::as<Rcpp::NumericVector>(sizes_sexp);
int n = Rcpp::as<int>(n_sexp);
conditionalPoissonArgs args;
args.weights.insert(args.weights.begin(), sizes.begin(), sizes.end());
args.n = n;
std::vector<mpfr_class> inclusionProbabilities;
args.zeroWeights.resize(sizes.size());
args.deterministicInclusion.resize(sizes.size());
args.indices.clear();
for(int i = 0; i != sizes.size(); i++)
{
args.zeroWeights[i] = args.deterministicInclusion[i] = false;
if(sizes[i] < 0 || sizes[i] > 1)
{
throw std::runtime_error("Sizes must be values in [0, 1]");
}
else if(sizes[i] == 0)
{
args.zeroWeights[i] = true;
}
else if(sizes[i] == 1)
{
args.deterministicInclusion[i] = true;
args.indices.push_back(i);
}
}
computeExponentialParameters(args);
conditionalPoissonInclusionProbabilities(args, inclusionProbabilities);
boost::numeric::ublas::matrix<mpfr_class> secondOrder(sizes.size(), sizes.size());
conditionalPoissonSecondOrderInclusionProbabilities(args, inclusionProbabilities, secondOrder);
Rcpp::NumericMatrix result(sizes.size(), sizes.size());
for(int i = 0; i < sizes.size(); i++)
{
for(int j = 0; j < sizes.size(); j++)
{
result(i, j) = secondOrder(i, j).convert_to<double>();
}
}
return result;
END_RCPP
}
void SerialPush_0Breaks_Functions(Rcpp::NumericVector S0, Rcpp::NumericVector S1)
{
int length=S1.size();
Rcpp::NumericVector Slopes0(1),Slopes1(1);
Rcpp::NumericVector BreakPoints(2);
for (int compteur=0; compteur<length; compteur++){
Slopes0[0]=S0[compteur];Slopes1[0]=S1[compteur];
BreakPoints[0]=-numeric_limits<double>::infinity();
BreakPoints[1]=numeric_limits<double>::infinity();
//vectorofcpqfunctions_.push_back(cpqfunction(Slopes,BreakPoints,0));
MycpqfunctionList_.push_back(cpqfunction(Slopes0,Slopes1,BreakPoints,0.0));
}
}
merResp::merResp(Rcpp::NumericVector y, Rcpp::NumericVector weights,
Rcpp::NumericVector offset) throw (std::runtime_error)
: d_y(y), d_weights(weights), d_offset(offset),
d_mu(y.size()), d_sqrtrwt(y.size()), d_wtres(y.size()),
d_sqrtXwt(y.size(), 1) {
int nn = y.size();
if (weights.size() != nn || offset.size() != nn)
throw std::runtime_error(
"lengths of y, weights and offset must agree");
init();
}
// [[Rcpp::export]]
Rcpp::NumericVector parad(Rcpp::NumericVector x, Rcpp::NumericVector y){
int i,n,max;
n=x.size();
Rcpp::NumericVector product(n);
max=omp_get_max_threads();
omp_set_num_threads(max);
#pragma omp parallel for
for(i=0;i<n;i++){
product[i]=x[i]/y[i];
}
return(product);
}
merResp::merResp(Rcpp::NumericVector y)
throw (std::runtime_error)
: d_y(y), d_weights(y.size(), 1.0), d_offset(y.size()),
d_mu(y.size(), 0.), d_sqrtrwt(y.size(), 1.),
d_wtres(y.size()),
d_sqrtXwt(y.size(), 1) {
init();
}
//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
}
///********************************************************************
///** tam_rcpp_calc_exp_redefine_vector_na
// [[Rcpp::export]]
Rcpp::NumericVector tam_rcpp_calc_exp_redefine_vector_na( Rcpp::NumericVector A, double val )
{
int N = A.size();
Rcpp::NumericVector A1(N);
for( int nn=0;nn<N;nn++){
if ( R_IsNA( A[nn] ) ){
A1[nn] = val;
} else {
A1[nn] = A[nn];
}
}
//---- OUTPUT
return A1;
}
//[[Rcpp::export]]
extern "C" SEXP aggregategsSumSigma( SEXP SDs, SEXP DOFs, SEXP geneSets) {
Rcpp::NumericVector SD(SDs);
Rcpp::NumericVector DOF(DOFs);
Rcpp::List geneSet(geneSets);
//note this function assumes that each input is not NA
//calculates the sd and mindof in order , names are assigned in R
int n = SD.size();
int m = DOF.size();
int o = geneSet.size(); //we assume non-empty (reduce complexity)
arma::vec sumSigma(o); //there is a sumSigma for each geneSet
arma::vec finalDof(o);
//need to run the sapply function
for ( int i=0 ; i < o ; i++) { //running a for loop
SEXP nn = geneSet[i];
Rcpp::NumericVector index(nn);
int p = index.size();
arma::vec test(p);
//we subset before computing, and use the Rcpp index vector to avoid creating an unsigned vector as armadillo type
Rcpp::NumericVector sd = SD[index -1]; //converting to 0 based
Rcpp::NumericVector dof = DOF[index-1];
//fast copy pointer address without data cache copy armadillo variables
arma::vec asd(sd.begin(),sd.size(),false);
arma::colvec adof(dof.begin(),dof.size(),false);
test =(asd%asd)%(adof/(adof-2));
sumSigma(i) = sqrt(sum(test)); //summing the subsets
finalDof(i) = floor(min(adof));
}
return Rcpp::List::create( Rcpp::Named("SumSigma") = Rcpp::wrap(sumSigma),
Rcpp::Named("MinDof") = Rcpp::wrap(finalDof));
}
SEXP conditionalPoissonInclusion(SEXP sizes_sexp, SEXP n_sexp)
{
BEGIN_RCPP
Rcpp::NumericVector sizes = Rcpp::as<Rcpp::NumericVector>(sizes_sexp);
int n = Rcpp::as<int>(n_sexp);
conditionalPoissonArgs args;
args.weights.insert(args.weights.begin(), sizes.begin(), sizes.end());
args.n = n;
std::vector<mpfr_class> inclusionProbabilities;
args.zeroWeights.resize(sizes.size());
args.deterministicInclusion.resize(sizes.size());
args.indices.clear();
for(int i = 0; i != sizes.size(); i++)
{
args.zeroWeights[i] = args.deterministicInclusion[i] = false;
if(sizes[i] < 0 || sizes[i] > 1)
{
throw std::runtime_error("Sizes must be values in [0, 1]");
}
else if(sizes[i] == 0)
{
args.zeroWeights[i] = true;
}
else if(sizes[i] == 1)
{
args.deterministicInclusion[i] = true;
args.indices.push_back(i);
}
}
computeExponentialParameters(args);
conditionalPoissonInclusionProbabilities(args, inclusionProbabilities);
std::vector<double> inclusionProbabilities_double;
std::transform(inclusionProbabilities.begin(), inclusionProbabilities.end(), std::back_inserter(inclusionProbabilities_double), [](mpfr_class x){ return x.convert_to<double>(); });
return Rcpp::wrap(inclusionProbabilities_double);
END_RCPP
}
void MapTematikNaturalBreaks::createMapTematikNaturalBreaks()
{
Rcpp::NumericVector naturalBreaks ;
QString command;
try {
command = QString("n <- classIntervals(dframe[[\"%1\"]], n=%2, style=\"jenks\"); "
"nat <- n[[2]];").arg(var).arg(typeMap);
rconn.parseEvalQ(command.toStdString());
naturalBreaks = rconn["nat"];
} catch (...) {
}
QList<int> temp[naturalBreaks.size()-1];
for(int i=0; i<numvar.size(); i++){
if(numvar[i] <= naturalBreaks[1]){
temp[0].append(table->verticalHeaderItem(i)->text().toInt());
}else{
for(int j=2; j<naturalBreaks.size(); j++){
if(numvar[i] > naturalBreaks[j-1] && numvar[i] <= naturalBreaks[j]){
temp[j-1].append(table->verticalHeaderItem(i)->text().toInt());
}
}
}
}
QList<QList<int> > temp2;
for(int i=0; i<naturalBreaks.size()-1; i++){
temp2.append(temp[i]);
}
MapTematikConfig* configWidget = new MapTematikConfig(mviewResult,vv,rconn,temp2,var,typeMap.toInt());
setupResultViewVariableTypeChooser("Natural Breaks",var, temp2,naturalBreaks,configWidget);
}
