https://github.com/cran/kdevine
Revision 06a935fcd0daca8842f0d3138ff354753033c0ec authored by Thomas Nagler on 11 May 2021, 23:50:12 UTC, committed by cran-robot on 11 May 2021, 23:50:12 UTC
1 parent 950ccc0
Raw File
Tip revision: 06a935fcd0daca8842f0d3138ff354753033c0ec authored by Thomas Nagler on 11 May 2021, 23:50:12 UTC
version 0.4.3
Tip revision: 06a935f
evaluators.cpp
#include <Rcpp.h>
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;
}


back to top