R/stat_filledcontour.R

In abnormally-distributed/cvreg: Cross Validation and Robust Estimation Utilities

StatFilledContour <- ggplot2::ggproto(
  "StatFilledContour",
  ggplot2::Stat,
  required_aes = c("x", "y"),
  compute_group = function(self, data, scales, params) {

    x <- data$x
    y <- data$y

    dx = density(x, n = 50, kernel = "t", bw = "SJ", from = min(x), to = max(x))$y
    dy = density(y, n = 50, kernel = "t", bw = "SJ", from = min(y), to = max(y))$y

    wch = c(max(dx), max(dy))[which.max(c(max(dx), max(dy)))]
    dx = dx * solve(wch, 100)
    dy = dy * solve(wch, 100)
    if (any(dx < 0 )){
      dx = dx + abs(min(dx))
    }
    if (any(dy < 0 )){
      dy = dy + abs(min(dy))
    }
    dx = ((dx-min(dx))/(max(dx)-min(dx))) * max(dnorm(x, mean(x), sd(x)))
    dy = ((dy-min(dy))/(max(dy)-min(dy))) * max(dnorm(y, mean(y), sd(y)))

    z = tcrossprod(dx, dy)
    x = seq(min(x), max(x), len = 50)
    y = seq(min(y), max(y), len = 50)
    X = list(x = sort(x), y = sort(y), z = z)
    akima::interp2xyz(X, data.frame = TRUE)
  }
)

#' filled contour stat for ggplot2
#'
#'
#' @inheritParams ggplot2::geom_raster
#' @export
#' @examples
#' ggplot(iris, aes(x = Sepal.Length, y = Petal.Length)) +
#'    stat_filledcontour(aes(fill=stat(z))) +
#'    scale_fill_viridis_c()
#'
stat_filledcontour <- function(mapping = NULL, data = NULL, geom = "raster",
                      position = "identity", show.legend = NA, inherit.aes = TRUE, interpolate = TRUE, ...) {
  ggplot2::layer(
    stat = StatFilledContour,
    data = data, mapping = mapping, geom = geom, position = position,
    show.legend = show.legend, inherit.aes = inherit.aes, params = list(interpolate = interpolate, ...)
  )
}