R/convex_hull.R

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

StatHull <- ggplot2::ggproto(
  "StatHull",
  ggplot2::Stat,
  required_aes = c("x", "y"),
  compute_group = function(self, data, scales, level, params) {
    if (level < 0.50){
      stop("the hull must cover at least 50 percent of the data")
    }
    else if (level == 1){
      data[chull(data$x, data$y), ]
    }
    else if (level < 1){
      trim <- 1 - level
      wins <- function (x, trim = 0.2, na.rm = TRUE){
        trim <- trim / 2
        if ((trim < 0) | (trim > 0.5))
          stop("trimming must be reasonable")
        qtrim <- hdquantile(x, c(trim, 0.5, 1 - trim))
        xbot <- qtrim[1]
        xtop <- qtrim[3]
        if (trim < 0.5) {
          x[x < xbot] <- xbot
          x[x > xtop] <- xtop
        }
        else {
          x[!is.na(x)] <- qtrim[2]
        }
        return(x)
      }

      trim.x <- wins(data$x, trim)
      trim.y <- wins(data$y, trim)
      data[chull(trim.x, trim.y), ]
    }
  }
)

stat_hull <- function(mapping = NULL, data = NULL, geom = "polygon",
                            position = "identity", show.legend = NA,
                            inherit.aes = TRUE, level = 1, ...) {
  ggplot2::layer(
    stat = StatHull,
    data = data, mapping = mapping, geom = geom, position = position,
    level = level,
    show.legend = show.legend, inherit.aes = inherit.aes, params = list(...)
  )
}

#' Convex hull (aka convex envelope) geom for ggplot2
#'
#'
#' @inheritParams ggplot2::geom_polygon
#' @export
#' @examples
#' library(ggplot2)
#' ggplot(iris, aes(x = Sepal.Width, y = Sepal.Length, color = Species, fill = Species)) +
#'   geom_point() +
#'   geom_hull(alpha = 0.5)
#'

geom_hull <- function (mapping = NULL, data = NULL, stat = "hull", position = "identity",
                       level = 1, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE , ...) {
  ggplot2::layer(
    data = data, mapping = mapping, stat = stat, geom = ggplot2::GeomPolygon,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, level = level,  ...)
  )
}