#include using namespace Rcpp; // [[Rcpp::export]] NumericVector kern_gauss(const NumericVector x) { NumericVector out(x.size()); for (int i = 0; i < x.size(); ++i) { if ((fabs(x[i]) >= 5)){ out[i] = 0; } else { // normalize by 0.9999994267 because of truncation out[i] = exp(- 0.5 * pow(x[i], 2)) / (sqrt(2 * M_PI)) / 0.9999994267; } } return out; } // [[Rcpp::export]] NumericVector ikern_gauss(const NumericVector x) { NumericVector out(x.size()); NumericVector xx(1); for (int i = 0; i < x.size(); ++i) { if (x[i] <= -5.0) { out[i] = 0.0; } else if (x[i] > 5.0) { out[i] = 1.0; } else { xx[0] = x[i]; // pnorm(-5.0) = 2.866516e-07 out[i] = (pnorm(xx)[0] - 2.866516e-07) / 0.9999994267; } } return out; } // [[Rcpp::export]] NumericVector eval_kde1d(const NumericVector xsort, const NumericVector xev, const double xmin, const double xmax, const double bw) { // The vector xsort has to be in ascending order !!! NumericVector tmp(xev.size()); NumericVector out(xev.size()); NumericVector xeveff(xev.size()); NumericVector xevdst(xev.size()); double n = xsort.size(); for (int i = 0; i < xev.size(); ++i) { if ((xev[i] < xmin) | (xev[i] > xmax)) { out[i] = 0; } else { if (xev[i] < xsort[0] - 0.99 * bw) { xevdst[i] = xsort[0] - xev[i]; xeveff[i] = xsort[0] - 0.99 * bw; } else if (xev[i] > xsort[n - 1] + 0.99 * bw) { xevdst[i] = xev[i] - xsort[n - 1]; xeveff[i] = xsort[n - 1] + 0.99 * bw; } else { xeveff[i] = xev[i]; xevdst[i] = 0; } if (pow(xevdst[i], 2) > 5 * bw) { out[i] = 0; } else { tmp = kern_gauss((xsort - xeveff[i]) / bw); if(!(xmin != xmin)) tmp = tmp + kern_gauss((2 * xmin - xsort - xeveff[i]) / bw); if(!(xmax != xmax)) tmp = tmp + kern_gauss((2 * xmax - xsort - xeveff[i]) / bw); out[i] = sum(tmp) / (n * bw) * exp(- 0.5 * pow(xevdst[i], 2) / bw) ; } } } return out; } // [[Rcpp::export]] NumericVector eval_pkde1d(const NumericVector x, const NumericVector xev, const double xmin, const double xmax, const double bw) { NumericVector tmp(xev.size()); NumericVector out(xev.size()); double n = x.size(); for (int i = 0; i < xev.size(); ++i) { if (xev[i] <= xmin) { out[i] = 0; } else if (xev[i] >= xmax) { out[i] = 1; } else { // integrate kernels on regular data tmp = ikern_gauss((xev[i] - x) / bw); if (!(xmin != xmin)) { // substract integral up to xmin tmp += - ikern_gauss((xmin - x) / bw); // add integrals for reflected data below xmin tmp += ikern_gauss((2 * xmin - x - xmin) / bw); // substract integral up to xmin tmp += - ikern_gauss((2 * xmin - x - xev[i]) / bw); } if (!(xmax != xmax)) { // add integrals for reflected data above xmax tmp += ikern_gauss(-(2 * xmax - x - xev[i]) / bw); } out[i] = sum(tmp) / n; } } return out; } // [[Rcpp::export]] NumericVector eval_qkde1d(const NumericVector x, const NumericVector qev, const double xmin, const double xmax, const double bw) { NumericVector out(qev.size()), x0, x1, ans, val; ans = 0.0, val = 0.0; double tol = ::fmax(1e-10 * (x1[0] - x0[0]), 1e-10); for (int i = 0; i < qev.size(); ++i) { if (::fabs(qev[i]) < 1e-30) out[i] = (xmin != xmin) ? R_NegInf : xmin; if (::fabs(qev[i] - 1) < 1e-30) out[i] = (xmax != xmax) ? R_PosInf : xmin;; int br = 0; x0 = min(x) - 5 * bw; x1 = max(x) + 5 * bw; NumericVector ql = eval_pkde1d(x, x0, xmin, xmax, bw); NumericVector qh = eval_pkde1d(x, x1, xmin, xmax, bw); ql = ql - qev[i]; qh = qh - qev[i]; if (::fabs(ql[0]) <= tol) { ans = x0; br = 1; } if (::fabs(qh[0]) <= tol) { ans = x1; br = 1; } int maxit = 20; for (int it = 0; it < maxit; ++it) { ans[0] = (x0[0] + x1[0]) / 2.0; NumericVector val = eval_pkde1d(x, ans, xmin, xmax, bw); val[0] = val[0] - qev[i]; //stop if values become too close (avoid infinite loop) if (::fabs(val[0]) <= tol) br = 1; if (::fabs(x0[0] - x1[0]) <= tol) br = 1; if (val[0] > 0.0) { x1[0] = ans[0]; qh[0] = val[0]; } else { x0[0] = ans[0]; ql[0] = val[0]; } if (br == 1) break; } out[i] = ans[0]; } return out; }