Skip to content

Commit

Permalink
new function geom_draw
Browse files Browse the repository at this point in the history
  • Loading branch information
@Yunuuuu
Yunuuuu committed Jan 6, 2025
1 parent 932c978 commit 2c9c271
Show file tree
Hide file tree
Showing 10 changed files with 563 additions and 357 deletions.
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,6 +78,7 @@ Collate:
'fortify-matrix.R'
'fortify-upset.R'
'geom-draw.R'
'geom-draw2.R'
'geom-pie.R'
'geom-subrect.R'
'geom-tile3d.R'
Expand Down
2 changes: 2 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -408,6 +408,7 @@ export(cross_mark)
export(cross_none)
export(dendrogram_data)
export(draw_key_draw)
export(draw_key_draw2)
export(element_curve)
export(element_polygon)
export(element_rep)
Expand All @@ -427,6 +428,7 @@ export(free_lab)
export(free_space)
export(free_vp)
export(geom_draw)
export(geom_draw2)
export(geom_pie)
export(geom_rect3d)
export(geom_subrect)
Expand Down
270 changes: 74 additions & 196 deletions R/geom-draw.R
View file
Original file line number Diff line number Diff line change
@@ -1,84 +1,85 @@
#' Layer with customized draw function
#' Layer with Grid or Function
#'
#' Draw a ggplot2 layer using a grob or a function.
#'
#' @param draw Either a [grob][grid::grob] object or a function (can be
#' purrr-style) that accepts at least three arguments (`data`, `panel_params`
#' and `coord`) and returns a [grob][grid::grob].
#'
#' When `draw` is a function, it is used as the `draw_group`/`draw_panel`
#' function in a [Geom][ggplot2::Geom] `ggproto` object. You should always
#' call `coord$transform(data, panel_params)` inside the function `draw` to
#' obtain transformed data in the plot scales.
#'
#' @param type A single string of `r oxford_or(c("group", "panel"))`, `"group"`
#' draws geoms with `draw_group`, which displays multiple observations as one
#' geometric object, and `"panel"` draws geoms with `draw_panel`, displaying
#' individual graphical objects for each observation (row). Default:
#' `"group"`.
#'
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_point
#' @inheritParams geom_subrect
#' @details
#' `geom_draw` depends on the new aesthetics `draw`, which should always be
#' provided with [`scale_draw_manual()`], in which, we can provide a list of
#' functions that define how each cell's grob (graphical object) should be
#' drawn. This aesthetic allows you to replace the default rendering of cells
#' with custom behavior, making it possible to tailor the plot to specific
#' requirements.
#' @eval rd_gg_aesthetics("geom", "draw")
#' @details If you want to combine the functionality of multiple geoms, it can
#' typically be achieved by preparing the data for each geom inside the
#' `draw_*()` call and sending it off to the different geoms, collecting the
#' output in a [`grid::gList`] (a list of grobs) for `draw_group()` or a
#' [`grid::gTree`] (a grob containing multiple child grobs) for
#' `draw_panel()`.
#' @seealso <https://ggplot2.tidyverse.org/reference/ggplot2-ggproto.html>
#' @examples
#' library(grid)
#' ggplot(data.frame(value = letters[seq_len(5)], y = seq_len(5))) +
#' geom_draw(aes(x = 1, y = y, draw = value, fill = value)) +
#' scale_draw_manual(values = list(
#' a = function(x, y, width, height, fill) {
#' rectGrob(x, y,
#' width = width, height = height,
#' gp = gpar(fill = fill),
#' default.units = "native"
#' )
#' },
#' b = function(x, y, width, height, fill) {
#' rectGrob(x, y,
#' width = width, height = height,
#' gp = gpar(fill = fill),
#' default.units = "native"
#' )
#' },
#' c = function(x, y, width, height, fill) {
#' rectGrob(x, y,
#' width = width, height = height,
#' gp = gpar(fill = fill),
#' default.units = "native"
#' )
#' },
#' d = function(x, y, width, height, shape) {
#' gList(
#' pointsGrob(x, y, pch = shape),
#' # To ensure the rectangle color is shown in the legends, you
#' # must explicitly provide a color argument and include it in
#' # the `gpar()` of the graphical object
#' rectGrob(x, y, width, height,
#' gp = gpar(col = "black", fill = NA)
#' )
#' )
#' },
#' e = function(xmin, xmax, ymin, ymax) {
#' segmentsGrob(
#' xmin, ymin,
#' xmax, ymax,
#' gp = gpar(lwd = 2)
#' )
#' }
#' )) +
#' scale_fill_brewer(palette = "Dark2") +
#' theme_void()
#' text <- grid::textGrob(
#' "ggdraw",
#' x = c(0, 0, 0.5, 1, 1),
#' y = c(0, 1, 0.5, 0, 1),
#' hjust = c(0, 0, 0.5, 1, 1),
#' vjust = c(0, 1, 0.5, 0, 1)
#' )
#' ggplot(data.frame(x = 1, y = 2)) +
#' geom_draw(text)
#' @importFrom rlang list2 arg_match0
#' @importFrom ggplot2 ggproto
#' @export
geom_draw <- function(mapping = NULL, data = NULL, stat = "identity",
geom_draw <- function(draw, mapping = NULL, data = NULL,
type = "group", stat = "identity",
position = "identity", ...,
lineend = "butt", linejoin = "mitre", na.rm = FALSE,
show.legend = NA, inherit.aes = TRUE) {
na.rm = FALSE, show.legend = FALSE, inherit.aes = TRUE) {
type <- arg_match0(type, c("group", "panel"))
draw <- allow_lambda(draw)
ggplot2::layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomDraw,
geom = switch(type,
panel = ggproto("GeomDraw",
ggplot2::Geom,
draw_panel = draw_fn,
draw_key = draw_key_draw
),
group = ggproto("GeomDraw",
ggplot2::Geom,
draw_group = draw_fn,
draw_key = draw_key_draw
)
),
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
lineend = lineend,
linejoin = linejoin,
na.rm = na.rm, ...
)
params = list(na.rm = na.rm, draw = draw, params = list2(...))
)
}

draw_fn <- function(data, panel_params, coord, draw, params) {
if (is.grob(draw) || is.gList(draw)) {
draw
} else {
draw <- rlang::as_function(draw)

# restore width and height
data$color <- data$colour
inject(draw(data, panel_params, coord, !!!params))
}
}

#' @inherit ggplot2::draw_key_point
#' @description
#' Each geom has an associated function that draws the key when the geom needs
Expand All @@ -88,145 +89,22 @@ geom_draw <- function(mapping = NULL, data = NULL, stat = "identity",
#' argument. The `draw_key_draw` function provides this interface for custom key
#' glyphs used with [`geom_draw()`].
#'
#' @importFrom rlang inject
#' @importFrom methods formalArgs
#' @importFrom ggplot2 zeroGrob
#' @importFrom grid gTree
#' @export
draw_key_draw <- function(data, params, size) {
draw <- .subset2(data$draw, 1L)
if (!is.function(draw)) return(zeroGrob()) # styler: off
data$draw <- NULL
args <- formalArgs(draw)
for (aes in args) {
if (is.null(.subset2(data, aes))) {
data[[aes]] <- switch(aes,
x = ,
y = 0.5,
xmin = ,
ymin = 0,
xmax = ,
ymax = 1,
width = ,
height = 1,
color = data$colour %||% GeomDraw$default_aes[["colour"]],
fill = data$colour %||% GeomDraw$default_aes[["fill"]],
GeomDraw$default_aes[[aes]]
)
}
}
if (any(args == "...")) {
ans <- inject(draw(!!!data))
} else {
ans <- inject(draw(!!!.subset(data, args)))
}
ans <- try_fetch(
draw_fn(data,
panel_params = NULL, coord = NULL,
draw = .subset2(params, "draw"),
params = .subset2(params, "params")
),
error = function(cnd) NULL
)
if (is.gList(ans)) ans <- gTree(children = ans)
if (is.grob(ans)) {
ans
} else {
zeroGrob()
}
}

combine_aes <- function(...) {
ans <- ...elt(1L)
for (i in 2:...length()) {
mapping <- ...elt(i)
for (nm in names(mapping)) {
ans[[nm]] <- .subset2(mapping, nm)
}
}
ans
}

#' @importFrom ggplot2 ggproto
#' @importFrom rlang inject
#' @importFrom methods formalArgs
#' @importFrom grid gList
GeomDraw <- ggproto(
"GeomDraw",
ggplot2::GeomTile,
required_aes = c(ggplot2::GeomTile$required_aes, "draw"),
default_aes = combine_aes(
ggplot2::GeomPoint$default_aes,
ggplot2::GeomRect$default_aes
),
draw_panel = function(data, panel_params, coord,
lineend = "butt", linejoin = "mitre") {
coords <- coord$transform(data, panel_params)
# restore width and height
coords$width <- coords$xmax - coords$xmin
coords$height <- coords$ymax - coords$ymin
coords$color <- coords$colour
indices <- vec_group_loc(.subset2(coords, "draw"))
ordering <- vapply(
.subset2(indices, "key"),
function(draw) {
attr(draw, "drawing_order", exact = TRUE) %||% NA_integer_
}, integer(1L),
USE.NAMES = FALSE
)
indices <- vec_slice(indices, order(ordering))
coords <- vec_chop(
coords[vec_set_difference(names(coords), "draw")],
indices = .subset2(indices, "loc")
)
grobs <- .mapply(function(draw, data) {
if (!is.function(draw)) return(NULL) # styler: off
args <- formalArgs(draw)
if (any(args == "...")) {
ans <- inject(draw(!!!data,
lineend = lineend, linejoin = linejoin
))
} else {
ans <- inject(draw(
!!!.subset(
c(data, list(lineend = lineend, linejoin = linejoin)), args
)
))
}
if (is.gList(ans)) {
gTree(children = ans)
} else {
ans
}
}, list(draw = .subset2(indices, "key"), data = coords), NULL)
grobs <- grobs[vapply(grobs, is.grob, logical(1L), USE.NAMES = FALSE)]
if (is_empty(grobs)) {
zeroGrob()
} else {
gTree(children = inject(gList(!!!grobs)))
}
},
draw_key = draw_key_draw
)

#' Scale for `draw` aesthetic
#'
#' @inheritDotParams ggplot2::discrete_scale -expand -position -aesthetics -palette -scale_name
#' @param values A list of functions (including purrr-like lambda syntax) that
#' define how each cell's grob (graphical object) should be drawn.
#' @inheritParams ggplot2::scale_discrete_manual
#' @inherit geom_draw
#' @export
scale_draw_manual <- function(..., values, aesthetics = "draw",
breaks = waiver(), na.value = NA) {
ggplot2::scale_discrete_manual(
aesthetics = aesthetics,
values = .mapply(function(f, i) {
f <- allow_lambda(f)
attr(f, "drawing_order") <- i # save the drawing order
f
}, list(values, seq_along(values)), NULL),
breaks = breaks,
na.value = na.value,
...
)
}

# `draw` should be provided manually
scale_draw_discrete <- function(name = waiver(), ...) {
cli_abort(
"You must provide {.field draw} scale with {.fn scale_draw_manual}"
)
}
Loading

0 comments on commit 2c9c271

Please sign in to comment.