Skip to content

Commit 692280b

Browse files
author
Yunuuuu
committed
refactor: adapt to S7 class system
1 parent 31ee5d2 commit 692280b

8 files changed

Lines changed: 173 additions & 178 deletions

‎NAMESPACE‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -154,7 +154,6 @@ S3method(ggupset,default)
154154
S3method(ggupset,waiver)
155155
S3method(grid.draw,ggalign::AlignPatches)
156156
S3method(grid.draw,patch_ggplot)
157-
S3method(grid.draw,patch_inset)
158157
S3method(heatmap_layout,default)
159158
S3method(length,ggalign_area)
160159
S3method(length,ggalign_pair_link)

‎R/alignpatch-inset.R‎

Lines changed: 69 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,19 @@
11
#' Create a ggplot inset
22
#'
3-
#' @inheritParams ggwrap
4-
#' @return A `patch_inset` object, which can be added in ggplot.
3+
#' @param plot Any graphic that can be converted into a [`grob`][grid::grob]
4+
#' using [`patch()`].
5+
#' @param ... Additional arguments passed to the [`patch()`] method.
6+
#' @param align A string specifying the area to place the plot: `"full"` for the
7+
#' full area, `"plot"` for the full plotting area (including the axis label), or
8+
#' `"panel"` for only the actual area where data is drawn.
9+
#' @param clip A single boolean value indicating whether the grob should be
10+
#' clipped if they expand outside their designated area.
11+
#' @param on_top A single boolean value indicates whether the graphic plot
12+
#' should be put frontmost. Note: the graphic plot will always put above the
13+
#' background.
14+
#' @param vp A [`viewport`][grid::viewport] object, you can use this to define
15+
#' the plot area.
16+
#' @return An `inset` object, which can be added to ggplot.
517
#' @inherit patch seealso
618
#' @examples
719
#' library(grid)
@@ -12,63 +24,66 @@
1224
#' p1 + inset(p2, vp = viewport(0.6, 0.6,
1325
#' just = c(0, 0), width = 0.4, height = 0.4
1426
#' ))
15-
#' @export
16-
inset <- function(
17-
plot,
18-
...,
19-
align = "panel",
20-
on_top = TRUE,
21-
clip = TRUE,
22-
vp = NULL) {
23-
make_inset(
24-
plot = plot,
25-
...,
26-
align = align,
27-
on_top = on_top,
28-
clip = clip,
29-
vp = vp
30-
)
31-
}
32-
33-
#' @importFrom grid editGrob
3427
#' @importFrom rlang arg_match0
35-
make_inset <- function(
36-
plot,
37-
...,
38-
align,
39-
on_top,
40-
clip,
41-
vp,
42-
call = caller_call()) {
43-
assert_bool(on_top, call = call)
44-
align <- arg_match0(align, c("panel", "plot", "full"), error_call = call)
45-
assert_bool(clip, call = call)
46-
assert_s3_class(vp, "viewport", allow_null = TRUE, call = call)
47-
if (!is.grob(grob <- patch(x = plot, ...))) {
48-
cli_abort("{.fn patch} must return a {.cls grob}", call = call)
49-
}
50-
if (!is.null(vp)) grob <- editGrob(grob, vp = vp)
51-
structure(
52-
list(
28+
#' @importFrom grid is.grob
29+
#' @importFrom S7 prop
30+
#' @export
31+
inset <- S7::new_class(
32+
"inset",
33+
properties = list(
34+
grob = S7::new_S3_class("grob"),
35+
vp = S7::new_union(NULL, S7::new_S3_class("viewport")),
36+
align = S7::new_property(
37+
S7::class_character,
38+
setter = function(self, value) {
39+
value <- arg_match0(
40+
value, c("panel", "plot", "full"),
41+
arg_nm = "@align"
42+
)
43+
prop(self, "align", check = FALSE) <- value
44+
self
45+
}
46+
),
47+
clip = S7::new_property(
48+
S7::class_character,
49+
setter = function(self, value) {
50+
assert_bool(value, arg = "@clip")
51+
prop(self, "clip", check = FALSE) <- if (value) "on" else "off"
52+
self
53+
}
54+
),
55+
on_top = S7::new_property(
56+
S7::class_logical,
57+
setter = function(self, value) {
58+
assert_bool(value, arg = "@on_top")
59+
prop(self, "on_top", check = FALSE) <- value
60+
self
61+
}
62+
)
63+
),
64+
constructor = function(plot, ..., align = "panel", on_top = TRUE,
65+
clip = TRUE, vp = NULL) {
66+
if (!is.grob(grob <- patch(x = plot, ...))) {
67+
cli_abort("{.fn patch} must return a {.cls grob} for {.obj_type_friendly {plot}}")
68+
}
69+
new_object(
70+
S7_object(),
5371
grob = grob,
72+
vp = vp,
5473
align = align,
55-
clip = if (clip) "on" else "off",
74+
clip = clip,
5675
on_top = on_top
57-
),
58-
class = "patch_inset"
59-
)
60-
}
76+
)
77+
}
78+
)
6179

6280
#' @importFrom grid grid.draw
63-
#' @export
64-
grid.draw.patch_inset <- function(x, recording = TRUE) {
65-
grid.draw(.subset2(x, "grob"))
66-
}
81+
local(S7::method(grid.draw, inset) <- function(x, recording = TRUE) {
82+
grid.draw(prop(x, "grob"))
83+
})
6784

6885
#' @importFrom ggplot2 update_ggplot
69-
S7::method(
70-
update_ggplot,
71-
list(S7::new_S3_class("patch_inset"), ggplot2::class_ggplot)
72-
) <- function(object, plot, object_name, ...) {
73-
make_wrap(plot, object)
74-
}
86+
S7::method(update_ggplot, list(inset, ggplot2::class_ggplot)) <-
87+
function(object, plot, objectname, ...) {
88+
make_wrap(plot, object)
89+
}

‎R/alignpatch-wrap.R‎

Lines changed: 19 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -5,19 +5,7 @@
55
#' adding any graphics that can be converted into a [`grob`][grid::grob] with
66
#' the [`patch()`] method.
77
#'
8-
#' @param plot Any graphic that can be converted into a [`grob`][grid::grob]
9-
#' using [`patch()`].
10-
#' @param ... Additional arguments passed to the [`patch()`] method.
11-
#' @param align A string specifying the area to place the plot: `"full"` for the
12-
#' full area, `"plot"` for the full plotting area (including the axis label), or
13-
#' `"panel"` for only the actual area where data is drawn.
14-
#' @param clip A single boolean value indicating whether the grob should be
15-
#' clipped if they expand outside their designated area.
16-
#' @param on_top A single boolean value indicates whether the graphic plot
17-
#' should be put frontmost. Note: the graphic plot will always put above the
18-
#' background.
19-
#' @param vp A [`viewport`][grid::viewport] object, you can use this to define
20-
#' the plot area.
8+
#' @inheritParams inset
219
#' @return A `wrapped_plot` object that can be directly placed into
2210
#' [`align_plots()`].
2311
#' @inherit patch seealso
@@ -37,7 +25,6 @@
3725
#' ))
3826
#'
3927
#' @importFrom ggplot2 theme element_blank ggplot
40-
#' @importFrom grid is.grob
4128
#' @export
4229
ggwrap <- function(plot, ..., align = "panel", on_top = FALSE,
4330
clip = TRUE, vp = NULL) {
@@ -46,32 +33,33 @@ ggwrap <- function(plot, ..., align = "panel", on_top = FALSE,
4633
plot.background = element_blank(),
4734
panel.background = element_blank()
4835
)
49-
inset <- make_inset(
50-
plot = plot, ..., align = align, on_top = on_top,
36+
patch_inset <- inset(
37+
plot = plot, ...,
38+
align = align, on_top = on_top,
5139
clip = clip, vp = vp
5240
)
53-
make_wrap(patch, inset)
41+
make_wrap(patch, patch_inset)
5442
}
5543

56-
make_wrap <- function(patch, inset) UseMethod("make_wrap")
44+
make_wrap <- function(patch, patch_inset) UseMethod("make_wrap")
5745

58-
make_wrapped_plot <- function(patch, inset) {
59-
if (.subset2(inset, "on_top")) {
46+
make_wrapped_plot <- function(patch, patch_inset) {
47+
if (prop(patch_inset, "on_top")) {
6048
patch$ggalign_wrapped_insets_above <- c(
61-
patch$ggalign_wrapped_insets_above, list(inset)
49+
patch$ggalign_wrapped_insets_above, list(patch_inset)
6250
)
6351
} else {
6452
patch$ggalign_wrapped_insets_under <- c(
65-
patch$ggalign_wrapped_insets_under, list(inset)
53+
patch$ggalign_wrapped_insets_under, list(patch_inset)
6654
)
6755
}
6856
add_class(patch, "wrapped_plot")
6957
}
7058

7159
#' @export
72-
make_wrap.ggplot <- function(patch, inset) {
60+
make_wrap.ggplot <- function(patch, patch_inset) {
7361
patch <- add_class(patch, "patch_ggplot")
74-
make_wrap(patch, inset)
62+
make_wrap(patch, patch_inset)
7563
}
7664

7765
#' @export
@@ -142,12 +130,15 @@ add_wrapped_insets <- function(gt, insets, on_top) {
142130
gt
143131
}
144132

133+
#' @importFrom S7
134+
#' @importFrom grid editGrob
145135
#' @importFrom gtable gtable is.gtable gtable_add_grob
146-
add_wrapped_inset <- function(gt, inset, on_top, i) {
147-
align <- .subset2(inset, "align")
148-
clip <- .subset2(inset, "clip")
136+
add_wrapped_inset <- function(gt, patch_inset, on_top, i) {
137+
align <- prop(patch_inset, "align")
138+
clip <- prop(patch_inset, "clip")
149139
layout <- .subset2(gt, "layout")
150-
grob <- .subset2(inset, "grob")
140+
grob <- prop(patch_inset, "grob")
141+
if (!is.null(vp <- prop(patch_inset, "vp"))) grob <- editGrob(grob, vp = vp)
151142
if (on_top) {
152143
z <- Inf
153144
} else {

‎man/inset.Rd‎

Lines changed: 1 addition & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

tests/testthat/_snaps/inset/ggplot-add-patch-inset-produces-correct-plot-output.svg renamed to tests/testthat/_snaps/inset/ggplot-add-inset-produces-correct-plot-output.svg

Lines changed: 1 addition & 1 deletion
Loading

‎tests/testthat/_snaps/inset/grid-draw-inset-matches-inner-grob.svg‎

Lines changed: 72 additions & 0 deletions
Loading

0 commit comments

Comments
 (0)