R/geom-triangle.R

In houyunhuang/ggtriangle: Fast processing of matrix heatmap

#' Triangle Geom
#'
#' @eval rd_aesthetics("geom", "triangle")
#' @param linejoin the line join style.
#' @param r0 scala numeric value (in (0, 0.5]).
#' @param mode string (default is "lt-rb"), "lt-rb" means split into two
#'     triangles from top-left to bottom-right, "lb-rt" means split into
#'     two triangles from bottom-left to top-right
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_polygon
#' @rdname geom_triangle
#' @importFrom ggplot2 layer ggproto aes GeomPolygon draw_key_polygon
#' @importFrom grid grobTree
#' @export
geom_triangle <- function(mapping = NULL, data = NULL,
                          stat = "identity", position = "identity",
                          ...,
                          linejoin = "mitre",
                          r0 = 0.5,
                          mode = "lt-rb",
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE) {
  mode <- match.arg(mode, c("lt-rb", "lb-rt"))
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomTriangle,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      linejoin = linejoin,
      r0 = r0,
      mode = mode,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname geom_triangle
#' @format NULL
#' @usage NULL
#' @export
GeomTriangle <- ggproto(
  "GeomTriangle", GeomPolygon,
  draw_panel = function(self, data, panel_params, coord, linejoin = "mitre",
                        r0 = 0.5, mode = "lt-rb") {
    if(!is.null(data$fill)) {
      aesthetics <- setdiff(names(data), c("x", "y", "fill.upper", "fill.lower", "group"))
      polys <- lapply(split(data, seq_len(nrow(data))), function(row) {
        dd <- point_to_rectriangle(row$x, row$y, r0, mode)
        aes <- new_data_frame(row[aesthetics])[rep(1, 8), ]
        GeomPolygon$draw_panel(cbind(dd, aes), panel_params, coord)
      })
    } else {
      aesthetics <- setdiff(names(data), c("x", "y", "fill.upper", "fill.lower", "fill", "group"))
      polys <- lapply(split(data, seq_len(nrow(data))), function(row) {
        dd <- point_to_rectriangle(row$x, row$y, r0, mode)
        dd$fill <- ifelse(dd$group == 1, row$fill.upper, row$fill.lower)
        aes <- new_data_frame(row[aesthetics])[rep(1, 8), ]
        GeomPolygon$draw_panel(cbind(dd, aes), panel_params, coord)
      })
    }
    ggplot2:::ggname("geom_triangle", do.call("grobTree", polys))
  },
  default_aes = aes(colour = "grey35", fill = NULL, fill.upper = NA, fill.lower = NA, size = 0.25,
                    linetype = 1, alpha = NA),
  required_aes = c("x", "y"),
  draw_key = draw_key_triangle
)

#' @noRd
point_to_rectriangle <- function(x, y, r0 = 0.5, mode = c("lt-rb", "lb-rt")) {
  mode <- match.arg(mode)
  if(mode == "lt-rb") {
    xx <- c(x - r0, x + r0, x + r0, x - r0, x - r0, x - r0, x + r0, x - r0)
    yy <- c(y + r0, y + r0, y - r0, y + r0, y + r0, y - r0, y - r0, y + r0)
  } else {
    xx <- c(x - r0, x - r0, x + r0, x - r0, x - r0, x + r0, x + r0, x - r0)
    yy <- c(y + r0, y - r0, y + r0, y + r0, y - r0, y - r0, y + r0, y - r0)
  }
  new_data_frame(list(
    x = xx,
    y = yy,
    group = rep(c(1, 2), each = 4)
  ))
}