Release 0.4.0 (#31)

* bump version

* add weights argument (#29)

* remove unused variable (#26)

* fix edf computation for deg = 2

* bump version + update docs

* remove package cache on appveyor

* weighted bandwidth selection

* weighted fitting

* adjust R interface

* add unit tests

* a few more sanity checks

* update docs

* update docs

* fix devtools install link

* stabilize weighted quantiles

* ensure scale != 0 in case of too many ties

* remove stripping of debug symbols

* prepare release

* update docs

.Rbuildignore

@@ -1,3 +1,5 @@
+^docs$
+^_pkgdown\.yml$
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^\.travis\.yml$

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: kde1d
 Type: Package
 Title: Univariate Kernel Density Estimation
-Version: 0.2.1
+Version: 0.4.0
 Authors@R: c(
         person("Thomas", "Nagler",, "mail@tnagler.com", role = c("aut", "cre")),
         person("Thibault", "Vatter",, "thibault.vatter@gmail.com", role = c("aut"))
@@ -26,7 +26,7 @@ Imports:
     qrng,
     stats,
     utils
-RoxygenNote: 6.0.1
+RoxygenNote: 6.1.1
 Suggests: 
     testthat
 URL: https://github.com/tnagler/kde1d

NEWS.md

@@ -1,8 +1,14 @@
-# kde1d 0.2.1
+# kde1d 0.4.0
 
-BUG FIXES
+NEW FEATURE
+
+  * allow weights for observations via `kde1d(..., weights = )` (#29).
+
+BUG FIX
+
+  * stabilized bandwidth selection in presence of ties and outliers.
 
-  * fix bug in computation of effective degrees of freedom when `deg = 2`.
+  * keep debug symbols on Linux systems (following a request by Prof. Ripley).
 
 
 # kde1d 0.2.0

R/RcppExports.R

@@ -13,8 +13,8 @@
 #' @return `An Rcpp::List` containing the fitted density values on a grid and
 #'   additional information.
 #' @noRd
-fit_kde1d_cpp <- function(x, bw, xmin, xmax, deg) {
-    .Call('_kde1d_fit_kde1d_cpp', PACKAGE = 'kde1d', x, bw, xmin, xmax, deg)
+fit_kde1d_cpp <- function(x, bw, xmin, xmax, deg, weights) {
+    .Call('_kde1d_fit_kde1d_cpp', PACKAGE = 'kde1d', x, bw, xmin, xmax, deg, weights)
 }
 
 #' computes the pdf of a kernel density estimate by interpolation.
@@ -48,9 +48,14 @@ qkde1d_cpp <- function(x, R_object) {
 #' @param x vector of observations
 #' @param grid_size number of equally-spaced points over which binning is
 #' performed to obtain kernel functional approximation
+#' @param weights vector of weights for each observation (can be empty).
 #' @return the selected bandwidth
 #' @noRd
-select_bw_cpp <- function(x, bw, mult, discrete) {
-    .Call('_kde1d_select_bw_cpp', PACKAGE = 'kde1d', x, bw, mult, discrete)
+select_bw_cpp <- function(x, bw, mult, discrete, weights) {
+    .Call('_kde1d_select_bw_cpp', PACKAGE = 'kde1d', x, bw, mult, discrete, weights)
+}
+
+quan <- function(x, a, w) {
+    .Call('_kde1d_quan', PACKAGE = 'kde1d', x, a, w)
 }
 

R/kde1d.R

@@ -15,6 +15,7 @@
 #'   latter uses the direct plug-in methodology of Sheather and Jones (1991).
 #' @param deg degree of the polynomial; either `0`, `1`, or `2` for log-constant,
 #'   log-linear, and log-quadratic fitting, respectively.
+#' @param weights optional vector of weights for individual observations.
 #'
 #' @return An object of class `kde1d`.
 #'
@@ -80,28 +81,40 @@
 #' points(ordered(0:5, 0:5),               # add true density
 #'        dbinom(0:5, 5, 0.5), col = "red")
 #'
+#' ## weighted estimate
+#' x <- rnorm(100)                         # simulate data
+#' weights <- rexp(100)                    # weights as in Bayesian bootstrap
+#' fit <- kde1d(x, weights = weights)      # weighted fit
+#' plot(fit)                               # compare with unweighted fit
+#' lines(kde1d(x), col = 2)
+#'
 #' @importFrom cctools cont_conv
 #' @importFrom stats na.omit
 #' @export
-kde1d <- function(x, xmin = NaN, xmax = NaN, mult = 1, bw = NA, deg = 2) {
+kde1d <- function(x, xmin = NaN, xmax = NaN, mult = 1, bw = NA, deg = 2,
+                  weights = numeric(0)) {
     x <- na.omit(x)
     # sanity checks
-    check_arguments(x, mult, xmin, xmax, bw, deg)
+    check_arguments(x, mult, xmin, xmax, bw, deg, weights)
 
     # jittering for discrete variables
     x <- cctools::cont_conv(x)
 
     # bandwidth selection
-    bw <- select_bw_cpp(boundary_transform(x, xmin, xmax), bw, mult,
-                        length(attr(x, "i_disc")) == 1)
+    bw <- select_bw_cpp(boundary_transform(x, xmin, xmax),
+                        bw,
+                        mult,
+                        length(attr(x, "i_disc")) == 1,
+                        weights)
 
     # fit model
-    fit <- fit_kde1d_cpp(x, bw, xmin, xmax, deg)
+    fit <- fit_kde1d_cpp(x, bw, xmin, xmax, deg, weights)
 
     # add info
     fit$jitter_info <- attributes(x)
     fit$var_name <- colnames(x)
     fit$nobs <- length(x)
+    fit$weights <- weights
 
     # return as kde1d object
     class(fit) <- "kde1d"

R/kde1d_methods.R

@@ -72,10 +72,12 @@ pkde1d <- function(q, obj) {
         p <- pkde1d_cpp(q, obj)
     } else {
         if (!is.ordered(q))
+
             q <- ordered(q, obj$jitter_info$levels$x)
         x_all <- as.ordered(obj$jitter_info$levels$x)
         p_all <- dkde1d(x_all, obj)
-        p <- sapply(q, function(y) sum(p_all[x_all <= y]))
+        p_total <- sum(p_all)
+        p <- sapply(q, function(y) sum(p_all[x_all <= y] / p_total))
         p <- pmin(pmax(p, 0), 1)
     }
 

R/tools.R

@@ -15,8 +15,21 @@ check_boundary_violations <- function(x, xmin, xmax) {
 
 #' check and pre-process arguments passed to kde1d()
 #' @noRd
-check_arguments <- function(x, mult, xmin, xmax, bw, deg) {
+check_arguments <- function(x, mult, xmin, xmax, bw, deg, weights) {
     stopifnot(NCOL(x) == 1)
+    stopifnot(length(mult) == 1)
+    stopifnot(length(xmin) == 1)
+    stopifnot(length(xmax) == 1)
+    stopifnot(length(bw) == 1)
+    stopifnot(length(deg) == 1)
+
+    stopifnot(is.numeric(mult))
+    stopifnot(mult > 0)
+    stopifnot(is.numeric(xmin))
+    stopifnot(is.numeric(xmax))
+    stopifnot(is.numeric(xmax))
+    stopifnot(is.na(bw) | is.numeric(bw))
+    stopifnot(is.numeric(deg))
 
     if (!is.ordered(x) & is.factor(x))
         stop("Factors not allowed; use kdevine::kdevine() or cctools::cckde().")
@@ -34,6 +47,9 @@ check_arguments <- function(x, mult, xmin, xmax, bw, deg) {
 
     if (!(deg %in% 0:2))
         stop("deg must be either 0, 1, or 2.")
+
+    if ((length(weights) > 0) && (length(weights) != length(x)))
+        stop("x and weights must have same length.")
 }
 
 #' adjusts observations and evaluation points for boundary effects

README.md

@@ -28,7 +28,7 @@ install.packages("kde1d")
 
 ``` r
 # install.packages("devtools")
-devtools::install_github("tnagler/kde1d")
+devtools::install_github("tnagler/kde1d@dev")
 ```
 
 ### Examples
@@ -68,6 +68,15 @@ points(ordered(0:5, 0:5),               # add true density
        dbinom(0:5, 5, 0.5), col = "red")
 ```
 
+##### Weighted estimate
+``` r
+x <- rnorm(100)                         # simulate data
+weights <- rexp(100)                    # weights as in Bayesian bootstrap
+fit <- kde1d(x, weights = weights)      # weighted fit
+plot(fit)                               # compare with unweighted fit
+lines(kde1d(x), col = 2)
+```
+
 ### References
 
 Geenens, G. (2014). *Probit transformation for kernel density estimation on

cran-comments.md

@@ -1,3 +1,5 @@
+Update following a request by Prof. Ripley to remove unconditional stripping of debug symbols.
+
 ## Test environments
 * ubuntu 12.04 on travis-ci (release, devel, oldrel)
 * win-builder (devel)
@@ -6,6 +8,9 @@
 
 0 errors | 0 warnings | 0 notes
 
-## Reverse dependencies
+## revdepcheck results
+
+We checked 2 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package.
 
-rvinecopulib: 0 errors | 0 warnings | 0 notes
+ * We saw 0 new problems
+ * We failed to check 0 packages