Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 88 lines (82 sloc) 3.298 kb
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 87 88
#' 2d density estimation.
#'
#' @section Aesthetics:
#' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("stat", "density2d")}
#'
#' @param contour If \code{TRUE}, contour the results of the 2d density
#' estimation
#' @param n number of grid points in each direction
#' @param ... other arguments passed on to \code{\link{kde2d}}
#' @param na.rm If \code{FALSE} (the default), removes missing values with
#' a warning. If \code{TRUE} silently removes missing values.
#' @inheritParams stat_identity
#' @return A data frame in the same format as \code{\link{stat_contour}}
#' @importFrom MASS kde2d
#' @export
#' @examples
#' \donttest{
#' library("MASS")
#' data(geyser, "MASS")
#'
#' m <- ggplot(geyser, aes(x = duration, y = waiting)) +
#' geom_point() + xlim(0.5, 6) + ylim(40, 110)
#' m + geom_density2d()
#'
#' dens <- kde2d(geyser$duration, geyser$waiting, n = 50,
#' lims = c(0.5, 6, 40, 110))
#' densdf <- data.frame(expand.grid(duration = dens$x, waiting = dens$y),
#' z = as.vector(dens$z))
#' m + geom_contour(aes(z=z), data=densdf)
#'
#' m + geom_density2d() + scale_y_log10()
#' m + geom_density2d() + coord_trans(y="log10")
#'
#' m + stat_density2d(aes(fill = ..level..), geom="polygon")
#'
#' qplot(duration, waiting, data=geyser, geom=c("point","density2d")) +
#' xlim(0.5, 6) + ylim(40, 110)
#'
#' # If you map an aesthetic to a categorical variable, you will get a
#' # set of contours for each value of that variable
#' set.seed(4393)
#' dsmall <- diamonds[sample(nrow(diamonds), 1000), ]
#' qplot(x, y, data = dsmall, geom = "density2d", colour = cut)
#' qplot(x, y, data = dsmall, geom = "density2d", linetype = cut)
#' qplot(carat, price, data = dsmall, geom = "density2d", colour = cut)
#' d <- ggplot(dsmall, aes(carat, price)) + xlim(1,3)
#' d + geom_point() + geom_density2d()
#'
#' # If we turn contouring off, we can use use geoms like tiles:
#' d + stat_density2d(geom="tile", aes(fill = ..density..), contour = FALSE)
#' last_plot() + scale_fill_gradient(limits=c(1e-5,8e-4))
#'
#' # Or points:
#' d + stat_density2d(geom="point", aes(size = ..density..), contour = FALSE)
#' }
stat_density2d <- function (mapping = NULL, data = NULL, geom = "density2d", position = "identity",
na.rm = FALSE, contour = TRUE, n = 100, ...) {
  StatDensity2d$new(mapping = mapping, data = data, geom = geom,
  position = position, na.rm = na.rm, contour = contour, n = n, ...)
}

StatDensity2d <- proto(Stat, {
  objname <- "density2d"
  
  default_geom <- function(.) GeomDensity2d
  default_aes <- function(.) aes(colour = "#3366FF", size = 0.5)
  required_aes <- c("x", "y")

  
  calculate <- function(., data, scales, na.rm = FALSE, contour = TRUE, n = 100, ...) {
    df <- data.frame(data[, c("x", "y")])
    df <- remove_missing(df, na.rm, name = "stat_density2d", finite = TRUE)

    dens <- safe.call(kde2d, list(x = df$x, y = df$y, n = n,
      lims = c(scale_dimension(scales$x), scale_dimension(scales$y)), ...))
    df <- with(dens, data.frame(expand.grid(x = x, y = y), z = as.vector(z)))
    df$group <- data$group[1]
    
    if (contour) {
      StatContour$calculate(df, scales, ...)
    } else {
      names(df) <- c("x", "y", "density", "group")
      df$level <- 1
      df$piece <- 1
      df
    }
  }
})
Something went wrong with that request. Please try again.