1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * bandwidth.c by W. N. Venables and B. D. Ripley Copyright (C) 1994-2001
4 * Copyright (C) 2012-2020 The R Core Team
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21 #include <stdlib.h> //abs
22 #include <math.h>
23 #include <Rmath.h> // M_* constants
24 #include <Rinternals.h>
25
26 // or include "stats.h"
27 #ifdef ENABLE_NLS
28 #include <libintl.h>
29 #define _(String) dgettext ("stats", String)
30 #else
31 #define _(String) (String)
32 #endif
33
34 #define DELMAX 1000
35 /* Avoid slow and possibly error-producing underflows by cutting off at
36 plus/minus sqrt(DELMAX) std deviations */
37 /* Formulae (6.67) and (6.69) of Scott (1992), the latter corrected. */
38
bw_ucv(SEXP sn,SEXP sd,SEXP cnt,SEXP sh)39 SEXP bw_ucv(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
40 {
41 double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
42 int n = asInteger(sn), nbin = LENGTH(cnt);
43 double *x = REAL(cnt);
44 for (int i = 0; i < nbin; i++) {
45 double delta = i * d / h;
46 delta *= delta;
47 if (delta >= DELMAX) break;
48 term = exp(-delta / 4.) - sqrt(8.0) * exp(-delta / 2.);
49 sum += term * x[i];
50 }
51 u = (0.5 + sum/n) / (n * h * M_SQRT_PI);
52 // = 1 / (2 * n * h * sqrt(PI)) + sum / (n * n * h * sqrt(PI));
53 return ScalarReal(u);
54 }
55
bw_bcv(SEXP sn,SEXP sd,SEXP cnt,SEXP sh)56 SEXP bw_bcv(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
57 {
58 double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
59 int n = asInteger(sn), nbin = LENGTH(cnt);
60 double *x = REAL(cnt);
61
62 sum = 0.0;
63 for (int i = 0; i < nbin; i++) {
64 double delta = i * d / h; delta *= delta;
65 if (delta >= DELMAX) break;
66 term = exp(-delta / 4) * (delta * delta - 12 * delta + 12);
67 sum += term * x[i];
68 }
69 u = (1 + sum/(32.0*n)) / (2.0 * n * h * M_SQRT_PI);
70 // = 1 / (2 * n * h * sqrt(PI)) + sum / (64 * n * n * h * sqrt(PI));
71 return ScalarReal(u);
72 }
73
bw_phi4(SEXP sn,SEXP sd,SEXP cnt,SEXP sh)74 SEXP bw_phi4(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
75 {
76 double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
77 int n = asInteger(sn), nbin = LENGTH(cnt);
78 double *x = REAL(cnt);
79
80 for (int i = 0; i < nbin; i++) {
81 double delta = i * d / h; delta *= delta;
82 if (delta >= DELMAX) break;
83 term = exp(-delta / 2.) * (delta * delta - 6. * delta + 3.);
84 sum += term * x[i];
85 }
86 sum = 2. * sum + n * 3.; /* add in diagonal */
87 u = sum / ((double)n * (n - 1) * pow(h, 5.0)) * M_1_SQRT_2PI;
88 // = sum / (n * (n - 1) * pow(h, 5.0) * sqrt(2 * PI));
89 return ScalarReal(u);
90 }
91
bw_phi6(SEXP sn,SEXP sd,SEXP cnt,SEXP sh)92 SEXP bw_phi6(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
93 {
94 double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
95 int n = asInteger(sn), nbin = LENGTH(cnt);
96 double *x = REAL(cnt);
97
98 for (int i = 0; i < nbin; i++) {
99 double delta = i * d / h; delta *= delta;
100 if (delta >= DELMAX) break;
101 term = exp(-delta / 2) *
102 (delta * delta * delta - 15 * delta * delta + 45 * delta - 15);
103 sum += term * x[i];
104 }
105 sum = 2. * sum - 15. * n; /* add in diagonal */
106 u = sum / ((double)n * (n - 1) * pow(h, 7.0)) * M_1_SQRT_2PI;
107 // = sum / (n * (n - 1) * pow(h, 7.0) * sqrt(2 * PI));
108 return ScalarReal(u);
109 }
110
111 /*
112 Use double cnt as from R 3.4.0, as counts can exceed INT_MAX for
113 large n (65537 in the worse case but typically not at n = 1 million
114 for a smooth distribution -- and this is by default no longer used
115 for n > 500).
116 */
117
bw_den(SEXP nbin,SEXP sx)118 SEXP bw_den(SEXP nbin, SEXP sx)
119 {
120 int nb = asInteger(nbin), n = LENGTH(sx);
121 double xmin, xmax, rang, dd, *x = REAL(sx);
122
123 xmin = R_PosInf; xmax = R_NegInf;
124 for (int i = 0; i < n; i++) {
125 if(!R_FINITE(x[i]))
126 error(_("non-finite x[%d] in bandwidth calculation"), i+1);
127 if(x[i] < xmin) xmin = x[i];
128 if(x[i] > xmax) xmax = x[i];
129 }
130 rang = (xmax - xmin) * 1.01;
131 dd = rang / nb;
132
133 SEXP ans = PROTECT(allocVector(VECSXP, 2)),
134 sc = SET_VECTOR_ELT(ans, 1, allocVector(REALSXP, nb));
135 SET_VECTOR_ELT(ans, 0, ScalarReal(dd));
136 double *cnt = REAL(sc);
137 for (int i = 0; i < nb; i++) cnt[i] = 0.0;
138
139 for (int i = 1; i < n; i++) {
140 int ii = (int)(x[i] / dd);
141 for (int j = 0; j < i; j++) {
142 int jj = (int)(x[j] / dd);
143 cnt[abs(ii - jj)] += 1.0;
144 }
145 }
146
147 UNPROTECT(1);
148 return ans;
149 }
150
151 /* Input: counts for nb bins */
bw_den_binned(SEXP sx)152 SEXP bw_den_binned(SEXP sx)
153 {
154 int nb = LENGTH(sx);
155 int *x = INTEGER(sx);
156
157 SEXP ans = PROTECT(allocVector(REALSXP, nb));
158 double *cnt = REAL(ans);
159 for (int ib = 0; ib < nb; ib++) cnt[ib] = 0.0;
160
161 for (int ii = 0; ii < nb; ii++) {
162 double w = x[ii]; // avoid int overflows below
163 cnt[0] += w*(w-1.); // don't count distances to self
164 for (int jj = 0; jj < ii; jj++)
165 cnt[ii - jj] += w * x[jj];
166 }
167 cnt[0] *= 0.5; // counts in the same bin got double-counted
168
169 UNPROTECT(1);
170 return ans;
171 }
172