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