1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
#' Compute density of data.
#'
#' @param x Dataset (data frame, \code{grouped_df} or ggvis) object to work
#' with.
#' @param x_var,w_var Names of variables to use for x position, and for
#' weights.
#' @param kernel Smoothing kernel. See \code{\link{density}} for details.
#' @param trim If \code{TRUE}, the default, density estimates are trimmed to the
#' actual range of the data. If \code{FALSE}, they are extended by the
#' default 3 bandwidths (as specified by the \code{cut} parameter to
#' \code{\link{density}}).
#' @param ... Additional arguments passed on to \code{\link{density}}.
#' @param n Number of points (along x) to use in the density estimate.
#' @param na.rm If \code{TRUE} missing values will be silently removed,
#' otherwise they will be removed with a warning.
#' @return A data frame with columns:
#' \item{pred_}{regularly spaced grid of \code{n} locations}
#' \item{resp_}{density estimate}
#' @export
#' @examples
#' mtcars %>% compute_density(~mpg, n = 5)
#' mtcars %>% group_by(cyl) %>% compute_density(~mpg, n = 5)
#' mtcars %>% ggvis(~mpg) %>% compute_density(~mpg, n = 5) %>%
#' layer_points(~pred_, ~resp_)
compute_density <- function(x, x_var, w_var = NULL, kernel = "gaussian",
trim = FALSE, n = 256L, na.rm = FALSE, ...) {
UseMethod("compute_density")
}
#' @export
compute_density.data.frame <- function(x, x_var, w_var = NULL,
kernel = "gaussian",
trim = FALSE, n = 256L,
na.rm = FALSE, ...) {
assert_that(is.formula(x_var))
# Extract variables from data frame
x_val <- eval_vector(x, x_var)
# Special case zero-row input
if (length(x_val) == 0) {
return(data.frame(pred_ = numeric(0), resp_ = numeric(0)))
}
if (is.null(w_var)) {
w_val <- NULL
} else {
w_val <- eval_vector(x, w_var)
}
# Build call to density()
call <- make_call("density", quote(x_val), weights = quote(w_val),
kernel = kernel, n = n, na.rm = na.rm, ...)
if (trim) {
call$from <- min(x_val)
call$to <- max(x_val)
}
dens <- eval(call)
# Standardise output
data.frame(pred_ = dens$x, resp_ = dens$y)
}
#' @export
compute_density.grouped_df <- function(x, x_var, w_var = NULL,
kernel = "gaussian", trim = FALSE,
n = 256L, na.rm = FALSE, ...) {
dplyr::do(x, compute_density(., x_var = x_var, w_var = w_var,
kernel = kernel, trim = trim, n = n, na.rm = na.rm, ...))
}
#' @export
compute_density.ggvis <- function(x, x_var, w_var = NULL,
kernel = "gaussian", trim = FALSE,
n = 256L, na.rm = FALSE, ...) {
args <- list(x_var = x_var, w_var = w_var, kernel = kernel,
trim = trim, n = n, na.rm = na.rm, ...)
register_computation(x, args, "density", function(data, args) {
output <- do_call(compute_density, quote(data), .args = args)
preserve_constants(data, output)
})
}
|
