Skip to content

Commit 0fd6dd0

Browse files
author
Yunuuuu
committed
new function: link_tetragon()
1 parent 4777578 commit 0fd6dd0

File tree

9 files changed

+174
-49
lines changed

9 files changed

+174
-49
lines changed

‎NAMESPACE‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -227,7 +227,7 @@ S3method(link_to_location,ggalign_range_link)
227227
S3method(link_to_location,integer)
228228
S3method(link_to_location,list)
229229
S3method(link_to_location,waiver)
230-
S3method(makeContent,ggalignLinkGrob)
230+
S3method(makeContent,ggalignLinkTree)
231231
S3method(makeContent,ggalignMarkGtable)
232232
S3method(makeContent,ggalignRasterMagick)
233233
S3method(make_wrap,alignpatches)
@@ -456,6 +456,7 @@ export(layout_expand)
456456
export(layout_title)
457457
export(link_draw)
458458
export(link_line)
459+
export(link_tetragon)
459460
export(mark_draw)
460461
export(mark_line)
461462
export(mark_tetragon)
@@ -545,6 +546,8 @@ importFrom(grid,absolute.size)
545546
importFrom(grid,convertHeight)
546547
importFrom(grid,convertWidth)
547548
importFrom(grid,editGrob)
549+
importFrom(grid,gList)
550+
importFrom(grid,gTree)
548551
importFrom(grid,gpar)
549552
importFrom(grid,grid.draw)
550553
importFrom(grid,grob)
@@ -555,6 +558,7 @@ importFrom(grid,heightDetails)
555558
importFrom(grid,is.grob)
556559
importFrom(grid,is.unit)
557560
importFrom(grid,makeContent)
561+
importFrom(grid,setChildren)
558562
importFrom(grid,unit)
559563
importFrom(grid,unit.c)
560564
importFrom(grid,unitType)

‎R/cross-link.R‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,7 @@ cross_link <- function(link, data = waiver(), on_top = TRUE,
3232
}
3333

3434
#' @importFrom ggplot2 ggproto ggproto_parent
35-
#' @importFrom grid grob
35+
#' @importFrom grid gTree
3636
#' @include cross-none.R
3737
CrossLink <- ggproto("CrossLink", CrossNone,
3838
interact_layout = function(self, layout) {
@@ -134,11 +134,11 @@ CrossLink <- ggproto("CrossLink", CrossNone,
134134
) %||% unit(0, "mm")
135135

136136
# setup the grob
137-
grob <- inject(grob(
137+
grob <- inject(gTree(
138138
!!!.subset2(plot, "ggalign_link_data"),
139139
spacing1 = spacing,
140140
spacing2 = spacing,
141-
cl = "ggalignLinkGrob"
141+
cl = "ggalignLinkTree"
142142
))
143143
plot$ggalign_link_data <- NULL
144144

‎R/geom-draw.R‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -91,6 +91,7 @@ geom_draw <- function(mapping = NULL, data = NULL, stat = "identity",
9191
#' @importFrom rlang inject
9292
#' @importFrom methods formalArgs
9393
#' @importFrom ggplot2 zeroGrob
94+
#' @importFrom grid gTree
9495
#' @export
9596
draw_key_draw <- function(data, params, size) {
9697
draw <- .subset2(data$draw, 1L)
@@ -122,7 +123,7 @@ draw_key_draw <- function(data, params, size) {
122123
if (!inherits(ans, c("grob", "gList", "gTree"))) {
123124
return(zeroGrob())
124125
}
125-
if (inherits(ans, "gList")) ans <- grid::gTree(children = ans)
126+
if (inherits(ans, "gList")) ans <- gTree(children = ans)
126127
ans
127128
}
128129

@@ -140,6 +141,7 @@ combine_aes <- function(...) {
140141
#' @importFrom ggplot2 ggproto
141142
#' @importFrom rlang inject
142143
#' @importFrom methods formalArgs
144+
#' @importFrom grid gList
143145
GeomDraw <- ggproto(
144146
"GeomDraw",
145147
ggplot2::GeomTile,
@@ -188,7 +190,7 @@ GeomDraw <- ggproto(
188190
NULL
189191
}
190192
}, list(draw = .subset2(indices, "key"), data = coords), NULL)
191-
inject(grid::gList(!!!grobs[lengths(grobs) > 0L]))
193+
inject(gList(!!!grobs[lengths(grobs) > 0L]))
192194
},
193195
draw_key = draw_key_draw
194196
)

‎R/ggplot-helper.R‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -87,7 +87,9 @@ element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL,
8787
#' @importFrom grid gpar
8888
#' @importFrom ggplot2 element_grob
8989
#' @export
90-
element_grob.ggalign_element_polygon <- function(element, x, y,
90+
element_grob.ggalign_element_polygon <- function(element,
91+
x = c(0, 0.5, 1, 0.5),
92+
y = c(0.5, 1, 0.5, 0),
9193
fill = NULL,
9294
colour = NULL,
9395
linewidth = NULL,
@@ -141,7 +143,7 @@ element_curve <- function(colour = NULL, linewidth = NULL, linetype = NULL,
141143
)
142144
}
143145

144-
#' @importFrom grid gpar
146+
#' @importFrom grid gpar gTree gList
145147
#' @importFrom ggplot2 element_grob
146148
#' @export
147149
element_grob.ggalign_element_curve <- function(element, x = 0:1, y = 0:1,
@@ -199,7 +201,7 @@ element_grob.ggalign_element_curve <- function(element, x = 0:1, y = 0:1,
199201
...
200202
)
201203
})
202-
grid::gTree(children = inject(grid::gList(!!!ans)))
204+
gTree(children = inject(gList(!!!ans)))
203205
}
204206

205207
##########################################################################

‎R/link.R‎

Lines changed: 91 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,12 @@
99
#' `grob`, no drawing will occur. The input data for the function should
1010
#' include a data frame with the coordinates of the pair of observations to
1111
#' be linked.
12-
#' @inheritParams pair_links
12+
#' @inheritParams .link_draw
1313
#' @seealso
1414
#' - [`link_line()`]
1515
#' - [`.link_draw()`]
1616
#' @importFrom rlang is_empty inject
17+
#' @importFrom grid gTree gList
1718
#' @export
1819
link_draw <- function(.draw, ...) {
1920
if (!is.function(draw <- allow_lambda(.draw))) {
@@ -22,9 +23,7 @@ link_draw <- function(.draw, ...) {
2223
new_draw <- function(data) {
2324
ans <- lapply(data, draw)
2425
ans <- ans[vapply(ans, is.grob, logical(1L), USE.NAMES = FALSE)]
25-
if (!is_empty(ans)) {
26-
grid::gTree(children = inject(grid::gList(!!!ans)))
27-
}
26+
if (!is_empty(ans)) inject(gList(!!!ans))
2827
}
2928
.link_draw(new_draw, ...)
3029
}
@@ -42,7 +41,7 @@ link_draw <- function(.draw, ...) {
4241
#' a list, where each item is a data frame containing the coordinates of
4342
#' the pair of observations.
4443
#'
45-
#' @inheritParams link_draw
44+
#' @inheritParams pair_links
4645
#' @seealso [`link_draw()`]
4746
#' @export
4847
.link_draw <- function(.draw, ...) {
@@ -64,9 +63,9 @@ print.ggalign_link_draw <- function(x, ...) {
6463
invisible(x)
6564
}
6665

67-
#' Link the observations with a line
66+
#' Link the paired observations with a line
6867
#'
69-
#' @inheritParams link_draw
68+
#' @inheritParams .link_draw
7069
#' @param element A [`element_line()`][ggplot2::element_line] object. Vectorized
7170
#' fields will be recycled to match the total number of groups, or you can
7271
#' wrap the element with [`I()`] to recycle to match the drawing groups. The
@@ -85,17 +84,18 @@ link_line <- function(..., element = NULL) {
8584
}
8685
ans <- .link_draw(.draw = function(data) {
8786
data <- lapply(data, function(d) {
87+
# if the link is only in one side, we do nothing
8888
if (vec_unique_count(.subset2(d, ".hand")) < 2L) {
8989
return(NULL)
9090
}
9191
both <- .subset2(vec_split(d, .subset2(d, ".hand")), "val")
9292
data <- cross_join(.subset2(both, 1L), .subset2(both, 2L))
9393
data_frame0(
94-
x = vec_c(
94+
x = vec_interleave(
9595
(data$x.x + data$xend.x) / 2L,
9696
(data$x.y + data$xend.y) / 2L
9797
),
98-
y = vec_c(
98+
y = vec_interleave(
9999
(data$y.x + data$yend.x) / 2L,
100100
(data$y.y + data$yend.y) / 2L
101101
)
@@ -124,6 +124,78 @@ link_line <- function(..., element = NULL) {
124124
add_class(ans, "ggalign_link_line")
125125
}
126126

127+
#' Link the paired observations with a quadrilateral
128+
#'
129+
#' @inheritParams .link_draw
130+
#' @inheritParams mark_tetragon
131+
#' @export
132+
link_tetragon <- function(..., element = NULL) {
133+
assert_s3_class(element, "element_polygon", allow_null = TRUE)
134+
default <- calc_element("ggalign.polygon", complete_theme(theme_get()))
135+
if (is.null(element)) {
136+
element <- default
137+
} else {
138+
element <- ggplot2::merge_element(element, default)
139+
}
140+
.link_draw(.draw = function(data) {
141+
data <- lapply(data, function(d) {
142+
# if the link is only in one side, we do nothing
143+
if (vec_unique_count(.subset2(d, ".hand")) < 2L) {
144+
return(NULL)
145+
}
146+
both <- .subset2(vec_split(d, .subset2(d, ".hand")), "val")
147+
both <- lapply(both, function(link) {
148+
# find the consecutive groups
149+
index <- .subset2(link, "link_index")
150+
oindex <- order(index)
151+
group <- cumsum(c(0L, diff(index[oindex])) != 1L)
152+
153+
# restore the order
154+
group <- group[order(oindex)]
155+
156+
# split link into groups
157+
.subset2(vec_split(link, group), "val")
158+
})
159+
both <- vec_expand_grid(
160+
hand1 = .subset2(both, 1L),
161+
hand2 = .subset2(both, 2L)
162+
)
163+
ans <- .mapply(function(hand1, hand2) {
164+
data_frame0(
165+
x = vec_c(
166+
min(hand1$x), max(hand1$xend),
167+
max(hand2$xend), min(hand2$x)
168+
),
169+
y = vec_c(
170+
min(hand1$y), max(hand1$yend),
171+
max(hand2$yend), min(hand2$y)
172+
)
173+
)
174+
}, both, NULL)
175+
vec_rbind(!!!ans)
176+
})
177+
if (inherits(element, "AsIs")) {
178+
element <- element_rep_len(element,
179+
length.out = sum(list_sizes(data)) / 4L
180+
)
181+
} else {
182+
element <- element_rep_len(element, length.out = length(data))
183+
element <- element_vec_rep_each(element,
184+
times = list_sizes(data) / 4L
185+
)
186+
}
187+
data <- vec_rbind(!!!data)
188+
if (vec_size(data)) {
189+
element_grob(
190+
element,
191+
x = data$x, y = data$y,
192+
id.lengths = vec_rep(4L, vec_size(data) / 4L),
193+
default.units = "native"
194+
)
195+
}
196+
}, ...)
197+
}
198+
127199
# preDraw:
128200
# - makeContext
129201
# - pushvpgp
@@ -133,9 +205,9 @@ link_line <- function(..., element = NULL) {
133205
# postDraw:
134206
# - postDrawDetails: by default, do noting
135207
# - popgrobvp
136-
#' @importFrom grid makeContent unit convertHeight convertWidth viewport
208+
#' @importFrom grid makeContent convertHeight convertWidth gList setChildren
137209
#' @export
138-
makeContent.ggalignLinkGrob <- function(x) {
210+
makeContent.ggalignLinkTree <- function(x) {
139211
# Grab viewport information
140212
width <- convertWidth(unit(1, "npc"), "mm", valueOnly = TRUE)
141213
height <- convertHeight(unit(1, "npc"), "mm", valueOnly = TRUE)
@@ -232,11 +304,16 @@ makeContent.ggalignLinkGrob <- function(x) {
232304
link
233305
})
234306
}
307+
308+
# hand1 - hand2
235309
data <- .mapply(vec_rbind, coords, NULL)
236310
draw <- .subset2(x, "draw")
237-
if (is.grob(grob <- draw(data))) {
238-
makeContent(grob)
311+
if (is.grob(grob <- draw(data))) { # wrap single grob to a gList
312+
grob <- gList(grob)
313+
}
314+
if (inherits(grob, "gList")) {
315+
setChildren(x, grob)
239316
} else {
240-
grid::nullGrob()
317+
x
241318
}
242319
}

‎R/mark.R‎

Lines changed: 34 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@
1616
#' - [`mark_tetragon()`]
1717
#' - [`.mark_draw()`]
1818
#' @importFrom rlang is_empty inject
19+
#' @importFrom grid gTree gList
1920
#' @export
2021
mark_draw <- function(.draw, ...) {
2122
if (!is.function(draw <- allow_lambda(.draw))) {
@@ -27,7 +28,7 @@ mark_draw <- function(.draw, ...) {
2728
})
2829
ans <- ans[vapply(ans, is.grob, logical(1L), USE.NAMES = FALSE)]
2930
if (!is_empty(ans)) {
30-
grid::gTree(children = inject(grid::gList(!!!ans)))
31+
gTree(children = inject(gList(!!!ans)))
3132
}
3233
}
3334
.mark_draw(new_draw, ...)
@@ -178,12 +179,14 @@ mark_tetragon <- function(..., element = NULL) {
178179
)
179180
}
180181
data <- vec_rbind(!!!data)
181-
element_grob(
182-
element,
183-
x = data$x, y = data$y,
184-
id.lengths = vec_rep(4L, nrow(data) / 4L),
185-
default.units = "native"
186-
)
182+
if (vec_size(data)) {
183+
element_grob(
184+
element,
185+
x = data$x, y = data$y,
186+
id.lengths = vec_rep(4L, nrow(data) / 4L),
187+
default.units = "native"
188+
)
189+
}
187190
}, ...)
188191
}
189192

@@ -224,12 +227,14 @@ mark_triangle <- function(..., orientation = "plot", element = NULL) {
224227
vec_rbind(!!!tetragon_list)
225228
})
226229
data <- vec_rbind(!!!data)
227-
element_grob(
228-
element,
229-
x = data$x, y = data$y,
230-
id.lengths = vec_rep(3L, nrow(data) / 3L),
231-
default.units = "native"
232-
)
230+
if (vec_size(data)) {
231+
element_grob(
232+
element,
233+
x = data$x, y = data$y,
234+
id.lengths = vec_rep(3L, nrow(data) / 3L),
235+
default.units = "native"
236+
)
237+
}
233238
}, ...)
234239
}
235240

@@ -458,17 +463,22 @@ makeContent.ggalignMarkGtable <- function(x) {
458463
)
459464
coords <- list_drop_empty(coords)
460465
draw <- .subset2(data, "draw")
461-
if (!is.grob(grob <- draw(coords))) {
462-
return(NextMethod())
466+
if (inherits(grob <- draw(coords), "gList")) {
467+
grob <- gTree(children = grob)
468+
}
469+
if (is.grob(grob)) {
470+
layout <- .subset2(x, "layout")
471+
panels <- layout[
472+
grepl("^panel", .subset2(layout, "name")), ,
473+
drop = FALSE
474+
]
475+
x <- gtable_add_grob(
476+
x,
477+
grobs = grob,
478+
t = 1L, l = 1L, b = -1L, r = -1L,
479+
# always draw with panel area
480+
z = min(panels$z)
481+
)
463482
}
464-
layout <- .subset2(x, "layout")
465-
panels <- layout[grepl("^panel", .subset2(layout, "name")), , drop = FALSE]
466-
x <- gtable_add_grob(
467-
x,
468-
grobs = grob,
469-
t = 1L, l = 1L, b = -1L, r = -1L,
470-
# always draw with panel area
471-
z = min(panels$z)
472-
)
473483
NextMethod()
474484
}

‎_pkgdown.yml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -83,6 +83,7 @@ reference:
8383
- mark_tetragon
8484
- mark_draw
8585
- link_line
86+
- link_tetragon
8687
- link_draw
8788
- pair_links
8889

0 commit comments

Comments
 (0)