// [[Rcpp::export]]
NumericVector cpp_rbbinom(
const int& n,
const NumericVector& size,
const NumericVector& alpha,
const NumericVector& beta
) {
if (std::min({size.length(), alpha.length(), beta.length()}) < 1) {
Rcpp::warning("NAs produced");
return NumericVector(n, NA_REAL);
}
NumericVector x(n);
bool throw_warning = false;
for (int i = 0; i < n; i++)
x[i] = rng_bbinom(GETV(size, i), GETV(alpha, i), GETV(beta, i),
throw_warning);
if (throw_warning)
Rcpp::warning("NAs produced");
return x;
}
// [[Rcpp::export]]
NumericVector ptsThresh(NumericVector values,NumericVector endDates,int window){
int valuesLen = values.length();
NumericVector out = clone(values);
NumericVector startDates = endDates - window;
for (int i = 0; i < valuesLen; ++i){
LogicalVector idx = (endDates <= endDates[i]) & (endDates >= startDates[i]);
NumericVector valuesWindow = values[idx];
int lenCur = valuesWindow.length();
if (lenCur == 1){
out[i] = (1.4 / 1.3) * valuesWindow[i];
}
if (lenCur == 2){
out[i] = (1.5 / 2.4) * sum(valuesWindow);
}
if (lenCur == 3){
out[i] = (1.5 / 3.3) * sum(valuesWindow);
}
if (lenCur == 4){
out[i] = (1.5 / 4.0) * sum(valuesWindow);
}
if (lenCur >= 5){
std::nth_element(valuesWindow.begin(),valuesWindow.begin() + 5,valuesWindow.end());
out[i] = valuesWindow[4];
}
}
return out;
}
// [[Rcpp::export]]
NumericVector cpp_qhcauchy(
const NumericVector& p,
const NumericVector& sigma,
const bool& lower_tail = true,
const bool& log_prob = false
) {
if (std::min({p.length(), sigma.length()}) < 1) {
return NumericVector(0);
}
int Nmax = std::max({
p.length(),
sigma.length()
});
NumericVector q(Nmax);
NumericVector pp = Rcpp::clone(p);
bool throw_warning = false;
if (log_prob)
pp = Rcpp::exp(pp);
if (!lower_tail)
pp = 1.0 - pp;
for (int i = 0; i < Nmax; i++)
q[i] = invcdf_hcauchy(GETV(pp, i), GETV(sigma, i),
throw_warning);
if (throw_warning)
Rcpp::warning("NaNs produced");
return q;
}
// [[Rcpp::export]]
NumericVector cpp_phcauchy(
const NumericVector& x,
const NumericVector& sigma,
bool lower_tail = true, bool log_prob = false
) {
if (std::min({x.length(), sigma.length()}) < 1) {
return NumericVector(0);
}
int Nmax = std::max({
x.length(),
sigma.length()
});
NumericVector p(Nmax);
bool throw_warning = false;
for (int i = 0; i < Nmax; i++)
p[i] = cdf_hcauchy(GETV(x, i), GETV(sigma, i),
throw_warning);
if (!lower_tail)
p = 1.0 - p;
if (log_prob)
p = Rcpp::log(p);
if (throw_warning)
Rcpp::warning("NaNs produced");
return p;
}
// [[Rcpp::export]]
NumericVector cpp_rlst(
const int& n,
const NumericVector& nu,
const NumericVector& mu,
const NumericVector& sigma
) {
if (std::min({nu.length(), mu.length(), sigma.length()}) < 1) {
Rcpp::warning("NAs produced");
return NumericVector(n, NA_REAL);
}
NumericVector x(n);
bool throw_warning = false;
for (int i = 0; i < n; i++)
x[i] = rng_lst(GETV(nu, i), GETV(mu, i),
GETV(sigma, i), throw_warning);
if (throw_warning)
Rcpp::warning("NAs produced");
return x;
}
// [[Rcpp::export]]
NumericVector cpp_dbern(
const NumericVector& x,
const NumericVector& prob,
const bool& log_prob = false
) {
if (std::min({x.length(), prob.length()}) < 1) {
return NumericVector(0);
}
int Nmax = std::max({
x.length(),
prob.length()
});
NumericVector p(Nmax);
bool throw_warning = false;
for (int i = 0; i < Nmax; i++)
p[i] = pdf_bernoulli(GETV(x, i), GETV(prob, i),
throw_warning);
if (log_prob)
p = Rcpp::log(p);
if (throw_warning)
Rcpp::warning("NaNs produced");
return p;
}
// [[Rcpp::export]]
NumericVector cpp_dhcauchy(
const NumericVector& x,
const NumericVector& sigma,
const bool& log_prob = false
) {
if (std::min({x.length(), sigma.length()}) < 1) {
return NumericVector(0);
}
int Nmax = std::max({
x.length(),
sigma.length()
});
NumericVector p(Nmax);
bool throw_warning = false;
for (int i = 0; i < Nmax; i++)
p[i] = logpdf_hcauchy(GETV(x, i), GETV(sigma, i),
throw_warning);
if (!log_prob)
p = Rcpp::exp(p);
if (throw_warning)
Rcpp::warning("NaNs produced");
return p;
}
// we process each dimension individually using this function
RcppExport SEXP noSplitcv(SEXP R_x,SEXP R_xv,SEXP R_ngroup, SEXP R_xtest,SEXP R_ngrouptest ,SEXP R_args){
NumericVector x(R_x);
NumericVector xv(R_xv);
NumericVector xtest(R_xtest);
NumericVector ngroup(R_ngroup);
NumericVector ngrouptest(R_ngrouptest);
List args(R_args);
std::string weights = Rcpp::as<std::string>(args["weights"]);
double gamma = Rcpp::as<double>(args["gamma"]);
double epsilon = Rcpp::as<double>(args["epsilon"]);
NumericMatrix W = args["W"];
NumericVector lambdalist = args["lambdalist"];
NumericVector error(lambdalist.length());
vector<double> sl = calculateSlope(x,ngroup,xv,weights,gamma,W,x.length());
Group *G = maketree(&x[0], x.length(), &sl[0],&ngroup[0],epsilon);
error_cv(G,&lambdalist[0],lambdalist.length(),&xtest[0], &ngrouptest[0],&error[0]);
delete_tree(G);
return(error);
}
// [[Rcpp::export]]
NumericVector cpp_rprop(
const int& n,
const NumericVector& size,
const NumericVector& mean,
const NumericVector& prior
) {
if (std::min({size.length(), mean.length(), prior.length()}) < 1) {
Rcpp::warning("NAs produced");
return NumericVector(n, NA_REAL);
}
NumericVector x(n);
bool throw_warning = false;
for (int i = 0; i < n; i++)
x[i] = rng_prop(GETV(size, i), GETV(mean, i),
GETV(prior, i), throw_warning);
if (throw_warning)
Rcpp::warning("NAs produced");
return x;
}
NumericMatrix rbindCpp(NumericVector a, NumericVector b){
if( a.length() != b.length() )
stop("rbind failed due to mismatch in length");
NumericMatrix out(2, a.length());
out(0,_) = a;
out(1,_) = b;
return(out);
}
void samplingControl::setSliceWidths(NumericVector inWidths)
{
if (inWidths.length() != 11)
{
::Rf_error("Slice widths must have length 11.\n");
}
int i;
for (i = 0; i < inWidths.length(); i++)
{
sliceWidths[i] = inWidths[i];
}
}
void exposureModel::setOffset(NumericVector offsets)
{
if (offsets.length() != (nTpt))
{
Rcpp::Rcout << "Error: offsets must have length equal to the number of time points.\n";
Rcpp::stop("Invalid offsets.");
}
int i;
for (i = 0; i < offsets.length(); i++)
{
offset(i) = offsets(i);
}
}
Rcpp::NumericVector rmvnorm(NumericVector mu, NumericMatrix eig_sigma) {
NumericVector Z = no_init(mu.length());
for (int i = 0; i < Z.length(); i++)
Z[i] = R::norm_rand();
NumericVector X = mu;
for (int i = 0; i < X.length(); i++) {
for (int j = 0; j < X.length(); j++) {
X[i] += eig_sigma(i,j) * Z[j];
}
}
return X;
}
//' FITS image writer
//'
//' Writes a vector, matrix or 3D array to a FITS file as an image.
//' The data is written to the primary HDU.
//'
// [[Rcpp::export]]
int gv_writefits_img(NumericVector img, CharacterVector fits_name, CharacterVector hdu_name = "")
{
IntegerVector dim;
if (!img.hasAttribute("dim"))
{
REprintf("ERROR: image has not been dimensioned.\n");
return 1;
}
dim = img.attr("dim");
if (dim.length() > 3)
{
REprintf("ERROR: dimension of more than 3 unsupported.\n");
return 1;
}
fitsfile *pfits=NULL;
int err=0;
std::string fname = as<std::string>(fits_name[0]);
fits_create_file(&pfits, (char *) fname.c_str(), &err);
if (err)
{
gv_print_fits_err(err);
return err;
}
#ifdef GV_DEBUG
Rcout << "Number of dim: " << dim.length() << std::endl;
for (int i=0; i<dim.length(); i++)
{
Rcout << "Dim[" << i << "]: " << dim[i] << std::endl;
}
Rcout << "Number of elements: " << img.length() << std::endl;
double *p = &(*img.begin());
for (int i=0; i<img.length(); i++)
{
Rcout << "*(p+" << i << ") = " << *(p+i) << std::endl;
}
#endif
long longdim[3], startpix[3] = {1,1,1}; // default start
for (int i=0; i<dim.length(); i++) longdim[i] = (long) dim[i];
// start writing to file
fits_create_img(pfits, DOUBLE_IMG, dim.length(), longdim, &err);
fits_write_pix(pfits, TDOUBLE, startpix, img.length(), &(*img.begin()), &err);
fits_close_file(pfits, &err);
return err;
}
//' Finds a discord using brute force algorithm.
//'
//' @param ts the input timeseries.
//' @param w_size the sliding window size.
//' @param discords_num the number of discords to report.
//' @useDynLib jmotif
//' @export
//' @references Keogh, E., Lin, J., Fu, A.,
//' HOT SAX: Efficiently finding the most unusual time series subsequence.
//' Proceeding ICDM '05 Proceedings of the Fifth IEEE International Conference on Data Mining
//' @examples
//' discords = find_discords_brute_force(ecg0606[1:600], 100, 1)
//' plot(ecg0606[1:600], type = "l", col = "cornflowerblue", main = "ECG 0606")
//' lines(x=c(discords[1,2]:(discords[1,2]+100)),
//' y=ecg0606[discords[1,2]:(discords[1,2]+100)], col="red")
// [[Rcpp::export]]
Rcpp::DataFrame find_discords_brute_force(
NumericVector ts, int w_size, int discords_num) {
std::map<int, double> res;
VisitRegistry registry(ts.length());
registry.markVisited(ts.length() - w_size, ts.length());
// Rcout << "starting search of " << discords_num << " discords..." << "\n";
int discord_counter = 0;
while(discord_counter < discords_num){
discord_record rec = find_best_discord_brute_force(ts, w_size, ®istry);
// Rcout << "found a discord " << discord_counter << " at " << rec.index;
// Rcout << ", NN distance: " << rec.nn_distance << "\n";
if(rec.nn_distance == 0 || rec.index == -1){ break; }
res.insert(std::make_pair(rec.index, rec.nn_distance));
int start = rec.index - w_size;
if(start<0){
start = 0;
}
int end = rec.index + w_size;
if(end>=ts.length()){
end = ts.length();
}
// Rcout << "marking as visited from " << start << " to " << end << "\n";
registry.markVisited(start, end);
discord_counter = discord_counter + 1;
}
std::vector<int> positions;
std::vector<double > distances;
for(std::map<int, double>::iterator it = res.begin(); it != res.end(); it++) {
positions.push_back(it->first);
distances.push_back(it->second);
}
// make results
return Rcpp::DataFrame::create(
Named("nn_distance") = distances,
Named("position") = positions
);
}
//' Primary production
//'
//' @export
// [[Rcpp::export]]
NumericVector prod_BeFa(NumericVector chla, NumericVector irrad, NumericVector stemp, NumericVector daylength) {
NumericVector out(chla.length());
for (int i = 0; i < out.length(); i++) {
out[i] = opp_befa(chla[i], irrad[i], stemp[i], daylength[i]);
}
return out;
}
// [[Rcpp::export]]
NumericVector calc_rr_cds(NumericVector outcome, NumericMatrix covars) {
int nrow = covars.nrow(), ncol = covars.ncol();
if (outcome.length() != nrow) {
stop("length of outcome should be the same as the number of rows in covars");
}
NumericVector out(ncol);
out.attr("names") = colnames(covars);
for (int j = 0; j < ncol; j++) {
double outcomes1 = 0;
double outcomes0 = 0;
double n1 = 0;
double n0 = 0;
for (int i = 0; i < nrow; i++) {
double covar = covars(i,j);
if (covar == 0.0) {
n0 += 1;
outcomes0 += outcome(i);
} else {
n1 += 1;
outcomes1 += outcome(i);
}
}
double prev1 = outcomes1/n1;
double prev0 = outcomes0/n0;
double rr = prev1/prev0;
out(j) = rr;
}
return out;
}
//' Computes the convex minorant of a polygon.
//' @param x,y the coordinates of the polygon
//' @return vector of the y-coordinates of the convex minorant
//[[Rcpp::export]]
NumericVector convexMinorant(NumericVector x, NumericVector y) {
int ny = y.length();
NumericVector XX = x;
NumericVector XY = y;
vector<Point> P(ny);
for (int i = 0; i < ny; i++) {
P[i].x = XX[i];
P[i].y = XY[i];
}
vector<Point> convHull = convex_hull(P);
int nP = convHull.size();
vector<int> convHullX(nP);
vector<double> convHullY(nP);
for (int i = 0; i < nP; i++) {
convHullX[i] = convHull.at(i).x;
convHullY[i] = convHull.at(i).y;
}
NumericVector XXX = Rcpp::wrap(convHullX);
NumericVector XYY = Rcpp::wrap(convHullY);
NumericVector slopes = compute_slopes(XXX, XYY);
return slopes;
//return List::create(Named("slopes") = slopes, Named("x") = XXX, Named("y") = XYY);
}
// [[Rcpp::export]]
double distan_def(DataFrame df) {
// access the columns
NumericVector value = df["value"];
NumericVector weight = df["weight"];
NumericVector binary = df["binary"];
int i, n_act = 0, n_oth = 0, n = value.length();
double actecdf = weight[0], otherecdf = 0, actbin = binary[0], dis = 0;
for(i = 1; i < n; i++){
dis += (value[i] - value[i-1])*(actecdf - otherecdf)*(actecdf - otherecdf);
if(binary[i] == actbin){
actecdf += weight[i];
n_act++;
}
if(binary[i] == 1 - actbin){
otherecdf += weight[i];
n_oth++;
}
}
// return a distance
return corregir(n_act, n_oth, dis);
}
NumericVector ewma(
const NumericVector& x,
const double& lambda = 0.2,
const bool& na_prev = true
) {
if (lambda < 0 || lambda > 1) {
Rcpp::stop("lambda takes values between 0 and 1");
}
int n = x.length();
NumericVector z(n, NA_REAL);
z[0] = x[0];
for ( int i = 1; i < n; i++ ) {
if (R_IsNA(x[i])) {
if (na_prev) {
z[i] = z[i-1];
continue;
} else {
break;
}
}
z[i] = lambda * x[i] + (1 - lambda) * z[i-1];
}
return z;
}
RcppExport SEXP reloadPars(SEXP Rlongpars, SEXP Rpars, SEXP Rngroups, SEXP RJ)
{
BEGIN_RCPP
const NumericVector longpars(Rlongpars);
List pars(Rpars);
const int ngroups = as<int>(Rngroups);
const int J = as<int>(RJ);
int ind = 0;
for(int g = 0; g < ngroups; ++g){
List glist = pars[g];
for(int i = 0; i < (J+1); ++i){
S4 item = glist[i];
NumericVector p = item.slot("par");
int len = p.length();
for(int j = 0; j < len; ++j)
p(j) = longpars(ind+j);
ind += len;
item.slot("par") = p;
glist[i] = item;
}
pars[g] = glist;
}
return(pars);
END_RCPP
}
//testing initial system for particle filter
// [[Rcpp::export]]
List initPF(NumericMatrix data, NumericVector init_state, int n_particles){
//initialize system
int n_iter = data.nrow(); //number of iterations for main particle filter
NumericVector time_points = data(_,0); //extract time points to run model over
double loglike = 0.0;
NumericVector particle_current_state(Dimension(1,init_state.length(),n_particles));
NumericVector particle_traj(Dimension(n_iter,init_state.length(),n_particles));
double init_weight = 1 / Rcpp::as<double>(wrap(n_particles));
NumericVector particle_weight = NumericVector(n_particles,init_weight);
return(List::create(Named("n_iter")=n_iter,
Named("time_points")=time_points,
Named("loglike")=loglike,
Named("particle_current_state")=particle_current_state,
Named("particle_traj")=particle_traj,
Named("particle_weight")=particle_weight));
}
// [[Rcpp::export]]
double getlambdashrinkC(NumericVector y) {
double n=0;
int m=y.length();
double lambda;
for (int i=0;i<m;i++) {
n+=y[i];
}
NumericVector u=y/n;
NumericVector temp(m,1.0);
NumericVector varu=u*(temp-u)/(n-1);
double msp=0;
for (int i=0;i<m;i++) {
msp+=pow(u[i]-(1.0/m),2);
}
if (msp==0) {
lambda=1;
} else {
lambda=0;
for (int i=0;i<m;i++) {
lambda+=varu[i];
}
lambda=lambda/msp;
}
if (lambda>1) {
lambda=1;
}
if (lambda<0) {
lambda=0;
}
return lambda;
}
// [[Rcpp::export]]
NumericVector constrOptimC(NumericVector init, NumericMatrix ui, NumericVector ci){
double p[4] = {0, 5, 0, .5};
int n = init.length(), m=ci.length();
size_t nt = init.length(), mt = ci.length();
RcppGSL::vector<double> x(init);
RcppGSL::matrix<double> ui1(ui);
RcppGSL::vector<double> ci1(ci);
double mu_n= 1;
double *mu = &mu_n;
struct constr_par mypar={ui1, ci1, mu, p};
gsl_set_error_handler_off();
// Initiate multimin minimizer;
const gsl_multimin_fdfminimizer_type *T;
gsl_multimin_fdfminimizer *s;
T = gsl_multimin_fdfminimizer_vector_bfgs;
s = gsl_multimin_fdfminimizer_alloc (T, n);
// Claim minimizing function;
gsl_multimin_function_fdf my_func;
my_func.n = n;
my_func.f = RC;
my_func.df = dRC;
my_func.fdf = RdRC;
my_func.params = &mypar;
// Claim the original function;
gsl_multimin_function_fdf orig_func;
orig_func.n = n;
orig_func.f = FC;
orig_func.df = gradC;
orig_func.params = p;
// Initiate the constrained optimization structure;
struct constr_multimin my_constrOpitm = {s, my_func, orig_func, 1e-4, 100, 1e-05};
NumericVector out(n+1);
gsl_vector *opt;
opt = gsl_vector_alloc(nt);
double f;
f = my_constrOpitm.inner_multimin(x, opt);
out = my_constrOpitm.constr_optim(x);
gsl_vector_free(ci1); gsl_vector_free(x); gsl_vector_free(opt);
gsl_matrix_free(ui1);
return(out);
}
NumericVector pow15(NumericVector v){
int n = v.length();
NumericVector out(n);
for(int j = 0; j < n; j++)
out(j) = pow(v(j), 1.5);
return( out );
}
double splEval(NumericVector xnew){
gsl_set_error_handler_off();
int Nx1 = x1.length(), Nx2 = x2.length(), Nx3 = x3.length();
int x3_index = findInterval1(xnew(2), x3); //Find which discrete value it is in the 3rd dimension;
NumericVector y2(Nx2);
// Interpolate the first dimension conditional the other values;
for(int j=0; j<Nx2; j++){
y2(j) = spl_vec[(x3_index-1)*Nx2+j].splEval(xnew(0));
}
// Set up another spl object for the 2nd dimension;
struct spl spl2 = spl_init(x2, y2);
double out = spl2.splEval(xnew(1));
spl2.splfree();
return(out);
}
//' Likelihood function for time-varying microcephaly
//'
//' Calculates the likelihood of observing a vector of microcephaly births given the total number of births and microcephaly probabilities. Note that all vectors must be equal lengths.. Assuming binomial distribution.
//' @param microBirths the vector of observed microcephaly cases over time
//' @param allBirths the corresponding total number of births
//' @param probM the corresponding vector of microcephaly probabilities as calculated by generate_probM.
//' @return a single likelihood value
//' @export
//[[Rcpp::export]]
double likelihood_probM(NumericVector microBirths, NumericVector allBirths, NumericVector probM){
double lnlik = 0;
int max = probM.length();
for(int i = 0; i < max; ++i){
lnlik += R::dbinom(microBirths[i],allBirths[i],probM[i],1);
}
return(lnlik);
}
// [[Rcpp::export]]
double sigFunc(const double sigma,
const NumericVector x_i,
const double perplexity) {
const NumericVector xs = exp(- pow(x_i,2) / sigma);
const NumericVector softxs = xs / sum(xs);
const double p2 = - sum(log(softxs) / log(2)) / xs.length();
return pow(perplexity - p2, 2);
};
NumericVector pow2(NumericVector v){
int n = v.length();
NumericVector out(n);
for(int j = 0; j < n; j++)
out(j) = v(j) * v(j);
return( out );
}
// [[Rcpp::export]]
NumericVector diff_cpp(const NumericVector x, const int lag = 1) {
int n = x.length();
NumericVector y(n - lag);
for (int i = lag; i < n; i++) {
y[i - lag] = x[i] - x[i - lag];
}
return y;
}
