new function: link_tetragon()

Yunuuuu · Jan 2, 2025 · 0fd6dd0 · 0fd6dd0
1 parent 4777578
commit 0fd6dd0
Show file tree

Hide file tree

Showing 9 changed files with 174 additions and 49 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -227,7 +227,7 @@ S3method(link_to_location,ggalign_range_link)
 S3method(link_to_location,integer)
 S3method(link_to_location,list)
 S3method(link_to_location,waiver)
-S3method(makeContent,ggalignLinkGrob)
+S3method(makeContent,ggalignLinkTree)
 S3method(makeContent,ggalignMarkGtable)
 S3method(makeContent,ggalignRasterMagick)
 S3method(make_wrap,alignpatches)
@@ -456,6 +456,7 @@ export(layout_expand)
 export(layout_title)
 export(link_draw)
 export(link_line)
+export(link_tetragon)
 export(mark_draw)
 export(mark_line)
 export(mark_tetragon)
@@ -545,6 +546,8 @@ importFrom(grid,absolute.size)
 importFrom(grid,convertHeight)
 importFrom(grid,convertWidth)
 importFrom(grid,editGrob)
+importFrom(grid,gList)
+importFrom(grid,gTree)
 importFrom(grid,gpar)
 importFrom(grid,grid.draw)
 importFrom(grid,grob)
@@ -555,6 +558,7 @@ importFrom(grid,heightDetails)
 importFrom(grid,is.grob)
 importFrom(grid,is.unit)
 importFrom(grid,makeContent)
+importFrom(grid,setChildren)
 importFrom(grid,unit)
 importFrom(grid,unit.c)
 importFrom(grid,unitType)

diff --git a/R/cross-link.R b/R/cross-link.R
@@ -32,7 +32,7 @@ cross_link <- function(link, data = waiver(), on_top = TRUE,
 }
 
 #' @importFrom ggplot2 ggproto ggproto_parent
-#' @importFrom grid grob
+#' @importFrom grid gTree
 #' @include cross-none.R
 CrossLink <- ggproto("CrossLink", CrossNone,
     interact_layout = function(self, layout) {
@@ -134,11 +134,11 @@ CrossLink <- ggproto("CrossLink", CrossNone,
         ) %||% unit(0, "mm")
 
         # setup the grob
-        grob <- inject(grob(
+        grob <- inject(gTree(
             !!!.subset2(plot, "ggalign_link_data"),
             spacing1 = spacing,
             spacing2 = spacing,
-            cl = "ggalignLinkGrob"
+            cl = "ggalignLinkTree"
         ))
         plot$ggalign_link_data <- NULL
 

diff --git a/R/geom-draw.R b/R/geom-draw.R
@@ -91,6 +91,7 @@ geom_draw <- function(mapping = NULL, data = NULL, stat = "identity",
 #' @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)
@@ -122,7 +123,7 @@ draw_key_draw <- function(data, params, size) {
     if (!inherits(ans, c("grob", "gList", "gTree"))) {
         return(zeroGrob())
     }
-    if (inherits(ans, "gList")) ans <- grid::gTree(children = ans)
+    if (inherits(ans, "gList")) ans <- gTree(children = ans)
     ans
 }
 
@@ -140,6 +141,7 @@ combine_aes <- function(...) {
 #' @importFrom ggplot2 ggproto
 #' @importFrom rlang inject
 #' @importFrom methods formalArgs
+#' @importFrom grid gList
 GeomDraw <- ggproto(
     "GeomDraw",
     ggplot2::GeomTile,
@@ -188,7 +190,7 @@ GeomDraw <- ggproto(
                 NULL
             }
         }, list(draw = .subset2(indices, "key"), data = coords), NULL)
-        inject(grid::gList(!!!grobs[lengths(grobs) > 0L]))
+        inject(gList(!!!grobs[lengths(grobs) > 0L]))
     },
     draw_key = draw_key_draw
 )

diff --git a/R/ggplot-helper.R b/R/ggplot-helper.R
@@ -87,7 +87,9 @@ element_polygon <- function(fill = NULL, colour = NULL, linewidth = NULL,
 #' @importFrom grid gpar
 #' @importFrom ggplot2 element_grob
 #' @export
-element_grob.ggalign_element_polygon <- function(element, x, y,
+element_grob.ggalign_element_polygon <- function(element,
+                                                 x = c(0, 0.5, 1, 0.5),
+                                                 y = c(0.5, 1, 0.5, 0),
                                                  fill = NULL,
                                                  colour = NULL,
                                                  linewidth = NULL,
@@ -141,7 +143,7 @@ element_curve <- function(colour = NULL, linewidth = NULL, linetype = NULL,
     )
 }
 
-#' @importFrom grid gpar
+#' @importFrom grid gpar gTree gList
 #' @importFrom ggplot2 element_grob
 #' @export
 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,
             ...
         )
     })
-    grid::gTree(children = inject(grid::gList(!!!ans)))
+    gTree(children = inject(gList(!!!ans)))
 }
 
 ##########################################################################

diff --git a/R/link.R b/R/link.R
@@ -9,11 +9,12 @@
 #'   `grob`, no drawing will occur. The input data for the function should
 #'   include a data frame with the coordinates of the pair of observations to
 #'   be linked.
-#' @inheritParams pair_links
+#' @inheritParams .link_draw
 #' @seealso
 #'  - [`link_line()`]
 #'  - [`.link_draw()`]
 #' @importFrom rlang is_empty inject
+#' @importFrom grid gTree gList
 #' @export
 link_draw <- function(.draw, ...) {
     if (!is.function(draw <- allow_lambda(.draw))) {
@@ -22,9 +23,7 @@ link_draw <- function(.draw, ...) {
     new_draw <- function(data) {
         ans <- lapply(data, draw)
         ans <- ans[vapply(ans, is.grob, logical(1L), USE.NAMES = FALSE)]
-        if (!is_empty(ans)) {
-            grid::gTree(children = inject(grid::gList(!!!ans)))
-        }
+        if (!is_empty(ans)) inject(gList(!!!ans))
     }
     .link_draw(new_draw, ...)
 }
@@ -42,7 +41,7 @@ link_draw <- function(.draw, ...) {
 #'   a list, where each item is a data frame containing the coordinates of
 #'   the pair of observations.
 #'
-#' @inheritParams link_draw
+#' @inheritParams pair_links
 #' @seealso [`link_draw()`]
 #' @export
 .link_draw <- function(.draw, ...) {
@@ -64,9 +63,9 @@ print.ggalign_link_draw <- function(x, ...) {
     invisible(x)
 }
 
-#' Link the observations with a line
+#' Link the paired observations with a line
 #'
-#' @inheritParams link_draw
+#' @inheritParams .link_draw
 #' @param element A [`element_line()`][ggplot2::element_line] object. Vectorized
 #'   fields will be recycled to match the total number of groups, or you can
 #'   wrap the element with [`I()`] to recycle to match the drawing groups. The
@@ -85,17 +84,18 @@ link_line <- function(..., element = NULL) {
     }
     ans <- .link_draw(.draw = function(data) {
         data <- lapply(data, function(d) {
+            # if the link is only in one side, we do nothing
             if (vec_unique_count(.subset2(d, ".hand")) < 2L) {
                 return(NULL)
             }
             both <- .subset2(vec_split(d, .subset2(d, ".hand")), "val")
             data <- cross_join(.subset2(both, 1L), .subset2(both, 2L))
             data_frame0(
-                x = vec_c(
+                x = vec_interleave(
                     (data$x.x + data$xend.x) / 2L,
                     (data$x.y + data$xend.y) / 2L
                 ),
-                y = vec_c(
+                y = vec_interleave(
                     (data$y.x + data$yend.x) / 2L,
                     (data$y.y + data$yend.y) / 2L
                 )
@@ -124,6 +124,78 @@ link_line <- function(..., element = NULL) {
     add_class(ans, "ggalign_link_line")
 }
 
+#' Link the paired observations with a quadrilateral
+#'
+#' @inheritParams .link_draw
+#' @inheritParams mark_tetragon
+#' @export
+link_tetragon <- function(..., element = NULL) {
+    assert_s3_class(element, "element_polygon", allow_null = TRUE)
+    default <- calc_element("ggalign.polygon", complete_theme(theme_get()))
+    if (is.null(element)) {
+        element <- default
+    } else {
+        element <- ggplot2::merge_element(element, default)
+    }
+    .link_draw(.draw = function(data) {
+        data <- lapply(data, function(d) {
+            # if the link is only in one side, we do nothing
+            if (vec_unique_count(.subset2(d, ".hand")) < 2L) {
+                return(NULL)
+            }
+            both <- .subset2(vec_split(d, .subset2(d, ".hand")), "val")
+            both <- lapply(both, function(link) {
+                # find the consecutive groups
+                index <- .subset2(link, "link_index")
+                oindex <- order(index)
+                group <- cumsum(c(0L, diff(index[oindex])) != 1L)
+
+                # restore the order
+                group <- group[order(oindex)]
+
+                # split link into groups
+                .subset2(vec_split(link, group), "val")
+            })
+            both <- vec_expand_grid(
+                hand1 = .subset2(both, 1L),
+                hand2 = .subset2(both, 2L)
+            )
+            ans <- .mapply(function(hand1, hand2) {
+                data_frame0(
+                    x = vec_c(
+                        min(hand1$x), max(hand1$xend),
+                        max(hand2$xend), min(hand2$x)
+                    ),
+                    y = vec_c(
+                        min(hand1$y), max(hand1$yend),
+                        max(hand2$yend), min(hand2$y)
+                    )
+                )
+            }, both, NULL)
+            vec_rbind(!!!ans)
+        })
+        if (inherits(element, "AsIs")) {
+            element <- element_rep_len(element,
+                length.out = sum(list_sizes(data)) / 4L
+            )
+        } else {
+            element <- element_rep_len(element, length.out = length(data))
+            element <- element_vec_rep_each(element,
+                times = list_sizes(data) / 4L
+            )
+        }
+        data <- vec_rbind(!!!data)
+        if (vec_size(data)) {
+            element_grob(
+                element,
+                x = data$x, y = data$y,
+                id.lengths = vec_rep(4L, vec_size(data) / 4L),
+                default.units = "native"
+            )
+        }
+    }, ...)
+}
+
 # preDraw:
 #  - makeContext
 #  - pushvpgp
@@ -133,9 +205,9 @@ link_line <- function(..., element = NULL) {
 # postDraw:
 #  - postDrawDetails: by default, do noting
 #  - popgrobvp
-#' @importFrom grid makeContent unit convertHeight convertWidth viewport
+#' @importFrom grid makeContent convertHeight convertWidth gList setChildren
 #' @export
-makeContent.ggalignLinkGrob <- function(x) {
+makeContent.ggalignLinkTree <- function(x) {
     # Grab viewport information
     width <- convertWidth(unit(1, "npc"), "mm", valueOnly = TRUE)
     height <- convertHeight(unit(1, "npc"), "mm", valueOnly = TRUE)
@@ -232,11 +304,16 @@ makeContent.ggalignLinkGrob <- function(x) {
             link
         })
     }
+
+    # hand1 - hand2
     data <- .mapply(vec_rbind, coords, NULL)
     draw <- .subset2(x, "draw")
-    if (is.grob(grob <- draw(data))) {
-        makeContent(grob)
+    if (is.grob(grob <- draw(data))) { # wrap single grob to a gList
+        grob <- gList(grob)
+    }
+    if (inherits(grob, "gList")) {
+        setChildren(x, grob)
     } else {
-        grid::nullGrob()
+        x
     }
 }
diff --git a/R/mark.R b/R/mark.R
@@ -16,6 +16,7 @@
 #'  - [`mark_tetragon()`]
 #'  - [`.mark_draw()`]
 #' @importFrom rlang is_empty inject
+#' @importFrom grid gTree gList
 #' @export
 mark_draw <- function(.draw, ...) {
     if (!is.function(draw <- allow_lambda(.draw))) {
@@ -27,7 +28,7 @@ mark_draw <- function(.draw, ...) {
         })
         ans <- ans[vapply(ans, is.grob, logical(1L), USE.NAMES = FALSE)]
         if (!is_empty(ans)) {
-            grid::gTree(children = inject(grid::gList(!!!ans)))
+            gTree(children = inject(gList(!!!ans)))
         }
     }
     .mark_draw(new_draw, ...)
@@ -178,12 +179,14 @@ mark_tetragon <- function(..., element = NULL) {
             )
         }
         data <- vec_rbind(!!!data)
-        element_grob(
-            element,
-            x = data$x, y = data$y,
-            id.lengths = vec_rep(4L, nrow(data) / 4L),
-            default.units = "native"
-        )
+        if (vec_size(data)) {
+            element_grob(
+                element,
+                x = data$x, y = data$y,
+                id.lengths = vec_rep(4L, nrow(data) / 4L),
+                default.units = "native"
+            )
+        }
     }, ...)
 }
 
@@ -224,12 +227,14 @@ mark_triangle <- function(..., orientation = "plot", element = NULL) {
             vec_rbind(!!!tetragon_list)
         })
         data <- vec_rbind(!!!data)
-        element_grob(
-            element,
-            x = data$x, y = data$y,
-            id.lengths = vec_rep(3L, nrow(data) / 3L),
-            default.units = "native"
-        )
+        if (vec_size(data)) {
+            element_grob(
+                element,
+                x = data$x, y = data$y,
+                id.lengths = vec_rep(3L, nrow(data) / 3L),
+                default.units = "native"
+            )
+        }
     }, ...)
 }
 
@@ -458,17 +463,22 @@ makeContent.ggalignMarkGtable <- function(x) {
     )
     coords <- list_drop_empty(coords)
     draw <- .subset2(data, "draw")
-    if (!is.grob(grob <- draw(coords))) {
-        return(NextMethod())
+    if (inherits(grob <- draw(coords), "gList")) {
+        grob <- gTree(children = grob)
+    }
+    if (is.grob(grob)) {
+        layout <- .subset2(x, "layout")
+        panels <- layout[
+            grepl("^panel", .subset2(layout, "name")), ,
+            drop = FALSE
+        ]
+        x <- gtable_add_grob(
+            x,
+            grobs = grob,
+            t = 1L, l = 1L, b = -1L, r = -1L,
+            # always draw with panel area
+            z = min(panels$z)
+        )
     }
-    layout <- .subset2(x, "layout")
-    panels <- layout[grepl("^panel", .subset2(layout, "name")), , drop = FALSE]
-    x <- gtable_add_grob(
-        x,
-        grobs = grob,
-        t = 1L, l = 1L, b = -1L, r = -1L,
-        # always draw with panel area
-        z = min(panels$z)
-    )
     NextMethod()
 }
diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -83,6 +83,7 @@ reference:
   - mark_tetragon
   - mark_draw
   - link_line
+  - link_tetragon
   - link_draw
   - pair_links