R/geom_encircle.R

In vivid: Variable Importance and Variable Interaction Displays

# The geom_encircle function and associated code is kindly provided
# by Ben Bolker, and is adapted from code on thier github repository
# for the now defunct package ggalt. Thanks Ben!


#' @importFrom grid grobTree gpar
draw_key_hack <- function(data, params, size) {
  data$fill <- alpha(data$fill, data$alpha)
  data$alpha <- 1

  grid::grobTree(
    if (!is.na(data$fill)) grid::rectGrob(gp = gpar(col = NA, fill = data$fill)),
    draw_key_path(data, params)
  )
}


#' Geom for drawing encircling polygons around groups
#'
#' This geom is used internally by [geom_encircle_vivi()], but is exported
#' so that users can add it directly if desired.
#'
#' @export
GeomEncircle <- ggproto("GeomEncircle", Geom,
                        required_aes = c("x", "y"),
                        default_aes = aes(colour = "black",
                                          fill = NA, ## ???
                                          alpha = 1,
                                          linetype=1,
                                          size=1,
                                          s_shape=0.5,  ## corresponds to default shape in xspline of -0.5
                                          s_open=FALSE,
                                          expand=0.05,
                                          spread=0.1),
                        draw_key = draw_key_hack, ## ???

                        draw_group = function(data, panel_scales, coord) {
                          ## browser()
                          coords <- coord$transform(data, panel_scales)
                          first_row <- coords[1, , drop = FALSE]
                          rownames(first_row) <- NULL ## prevent warning later

                          m <- lapply(coords[,c("x","y")],mean,na.rm=TRUE)
                          ch <- grDevices::chull(coords[c("x","y")])

                          mkcoords <- function(x,y) {
                            data.frame(x,y,first_row[!names(first_row) %in% c("x","y")])
                          }

                          coords <- coords[ch,]


                          ## convert from lengths to physical units, for computing *directions*
                          cc <- function(x,dir="x")
                            grid::convertUnit(grid::unit(x,"native"),"mm",typeFrom="dimension",
                                              axisFrom=dir,valueOnly=TRUE)

                          ## convert back to native (e.g. native + snpc offset)
                          cc_inv <- function(x,dir="x")
                            grid::convertUnit(x,"native",typeFrom="location",
                                              axisFrom=dir,valueOnly=TRUE)

                          cc_comb <- function(x1,x2,dir="x")
                            cc_inv(unit(x1,"native")+unit(x2,"snpc"),dir=dir)

                          ## find normalized vector: d1 and d2 have $x, $y elements
                          normFun <- function(d1,d2) {
                            dx <- cc(d1$x-d2$x)
                            dy <- cc(d1$y-d2$y)
                            r <- sqrt(dx*dx+dy*dy)
                            list(x=dx/r,y=dy/r)
                          }

                          if (nrow(coords)==1) {
                            ## only one point: make a diamond by spreading points vertically
                            ## and horizontally
                            coords <- with(coords,
                                           mkcoords(
                                             c(x,x+spread,x,x-spread),
                                             c(y+spread,y,y-spread,y)))
                          } else if (nrow(coords)==2) {
                            ## only two points: make a diamond by spreading points perpendicularly
                            rot <- matrix(c(0,1,-1,0),2)
                            dd <- c(rot %*% unlist(normFun(coords[1,],coords[2,])))*
                              coords$spread
                            coords <- with(coords, {
                              ## figure out rotated values, then convert *back* to native units
                              ## already in scaled units, so ignore?
                              x <- c(x[1],
                                     m$x+dd[1], ## cc_comb(m$x,dd[1]),
                                     x[2],
                                     m$x-dd[1]) ## cc_comb(m$x,-dd[1]))
                              y <- c(y[1],
                                     m$y+dd[2], ## cc_comb(m$y,dd[2],"y"),
                                     y[2],
                                     m$y-dd[2]) ## cc_comb(m$y,-dd[2],"y"))
                              mkcoords(x,y)
                            })
                          }

                          disp <- normFun(coords,m)

                          ## browser()

                          gp <- grid::get.gpar()
                          pars1 <- c("colour","linetype","alpha","fill","size")
                          pars2 <- c("col","lty","alpha","fill","lwd")
                          gp[pars2] <- first_row[pars1]
                          grid::xsplineGrob(
                            with(coords,unit(x,"npc")+disp$x*unit(expand,"snpc")),
                            with(coords,unit(y,"npc")+disp$y*unit(expand,"snpc")),
                            ## coords$x,
                            ## coords$y,
                            shape = coords$s_shape-1,  ## kluge!
                            open = first_row$s_open,
                            gp = gp)
                        }
)

if (FALSE) {
  library("grid")
  library("gridBase")
  coords <- data.frame(x=c(1,1),y=c(1,2)*100,spread=c(0.1,0.1))
  plot(y~x,data=d,xlim=c(0,3),ylim=c(0,300))
  vps <- baseViewports()
  pushViewport(vps$inner)
  pushViewport(vps$figure)
  pushViewport(vps$plot)
  ## check that we're in the right place
  m <- as.list(colMeans(coords))
  grid.points(m$x,m$y,gp=gpar(col="red"))
  cc <- function(x,dir="x")
    grid::convertUnit(grid::unit(x,"native"),"mm",typeFrom="dimension",
                      axisFrom=dir,valueOnly=TRUE)
  cc_inv <- function(x,dir="x")
    grid::convertUnit(x,"native",typeFrom="location",
                      axisFrom=dir,valueOnly=TRUE)

  cc_comb <- function(x1,x2,dir="x")
    cc_inv(unit(x1,"native")+unit(x2,"snpc"),dir=dir)

  ## find normalized vector: d1 and d2 have $x, $y elements
  normFun <- function(d1,d2) {
    dx <- cc(d1$x-d2$x)
    dy <- cc(d1$y-d2$y)
    r <- sqrt(dx*dx+dy*dy)
    list(x=dx/r,y=dy/r)
  }

  dd <- c(rot %*% unlist(normFun(coords[1,],coords[2,])))*
    coords$spread
  z <- with(coords, {
    ## figure out rotated values, then convert *back* to native units
    x <- c(x[1],
           cc_comb(m$x,dd[1]),
           x[2],
           cc_comb(m$x,-dd[1]))
    y <- c(y[1],
           cc_comb(m$y,dd[2],"y"),
           y[2],
           cc_comb(m$y,-dd[2],"y"))
    list(x=x,y=y)
  })
  with(z,grid.points(x,y,gp=gpar(col="blue")))

  print(grid::convertWidth(unit(1,'npc'),'native'))
  print(grid::convertHeight(unit(1,'npc'),'native'))

}

#' Automatically enclose points in a polygon
#'
#' @details
#' This function adds a polygon around a set of points, to highlight them.
#'
#' @param mapping mapping
#' @param data  data
#' @param stat  stat
#' @param position position
#' @param na.rm na.rm
#' @param show.legend  show.legend
#' @param inherit.aes inherit.aes
#' @param ...  dots
#' @return adds a circle around the specified points
#' @export
#' @examples
#' library(ggplot2)
#' d <- data.frame(x=c(1,1,2),y=c(1,2,2)*100)
#'
#' gg <- ggplot2::ggplot(d,aes(x,y))
#' gg <- gg + scale_x_continuous(expand=c(0.5,1))
#' gg <- gg + scale_y_continuous(expand=c(0.5,1))
#'
#' gg + geom_encircle_vivi(s_shape=1, expand=0) + geom_point()
#'
#' gg + geom_encircle_vivi(s_shape=1, expand=0.1, colour="red") + geom_point()

geom_encircle_vivi <- function(mapping = NULL, data = NULL, stat = "identity",
                          position = "identity", na.rm = FALSE, show.legend = NA,
                          inherit.aes = TRUE, ...) {
  layer(
    geom = GeomEncircle, mapping = mapping,  data = data, stat = stat,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}