new argument obs_size to control the width

R/cross-link.R

@@ -13,18 +13,20 @@
 #' needed.
 #'
 #' @export
-cross_link <- function(link, data = waiver(), on_top = TRUE, reorder = NULL,
+cross_link <- function(link, data = waiver(), on_top = TRUE,
+                       reorder = NULL, obs_size = 1,
                        inherit_index = NULL, inherit_panel = NULL,
                        inherit_nobs = NULL,
                        size = NULL, active = NULL) {
     if (!inherits(link, "ggalign_link_draw")) {
         cli_abort("{.arg link} must be a {.fn link_draw} object")
     }
     reorder <- check_reorder(reorder)
+    assert_obs_size(obs_size)
     assert_active(active)
     active <- update_active(active, new_active(use = TRUE))
     cross(CrossLink,
-        data = data, link = link, reorder = reorder,
+        data = data, link = link, reorder = reorder, obs_size = obs_size,
         plot = ggplot(), size = size,
         schemes = default_schemes(th = theme_no_panel()),
         active = active,
@@ -121,7 +123,8 @@ CrossLink <- ggproto("CrossLink", Cross,
             link_index = link_index,
             data_index = data_index,
             direction = direction,
-            draw = .subset2(link, "draw")
+            draw = .subset2(link, "draw"),
+            obs_size = self$obs_size
         )
         plot
     },

R/cross-mark.R

@@ -23,18 +23,19 @@
 #' You can use [`scheme_data()`] to modify the internal data if needed.
 #'
 #' @export
-cross_mark <- function(mark, data = waiver(), reorder = NULL,
+cross_mark <- function(mark, data = waiver(), reorder = NULL, obs_size = 1,
                        inherit_index = NULL, inherit_panel = NULL,
                        inherit_nobs = NULL,
                        size = NULL, active = NULL) {
     if (!inherits(mark, "ggalign_mark_draw")) {
         cli_abort("{.arg mark} must be a {.fn mark_draw} object")
     }
     reorder <- check_reorder(reorder)
+    assert_obs_size(obs_size)
     assert_active(active)
     active <- update_active(active, new_active(use = TRUE))
     cross(CrossMark,
-        data = data, mark = mark, reorder = reorder,
+        data = data, mark = mark, reorder = reorder, obs_size = obs_size,
         plot = ggplot(), size = size,
         schemes = default_schemes(th = theme_add_panel()),
         active = active,
@@ -189,7 +190,8 @@ CrossMark <- ggproto("CrossMark", Cross,
             link_index = link_index,
             data_index = data_index,
             direction = direction,
-            draw = .subset2(mark, "draw")
+            draw = .subset2(mark, "draw"),
+            obs_size = self$obs_size
         )
         add_class(plot, "ggalign_mark_plot", "patch_ggplot")
     },

R/ggmark.R

@@ -11,6 +11,8 @@
 #'   layout's defined groups.
 #' @param reorder A string of `r oxford_or(c("hand1", "hand2"))` indicating
 #'   whether to reorder the input links to follow the specified layout ordering.
+#' @param obs_size A single numeric value that indicates the size of a single
+#'   observation, ranging from `(0, 1]`.
 #' @section ggplot2 specification:
 #' `ggmark` initializes a ggplot object. The underlying data is created using
 #' [`fortify_data_frame()`]. Please refer to it for more details.
@@ -57,11 +59,12 @@
 #' @export
 ggmark <- function(mark, data = waiver(), mapping = aes(), ...,
                    group1 = NULL, group2 = NULL, reorder = NULL,
-                   size = NULL, active = NULL) {
+                   obs_size = 1, size = NULL, active = NULL) {
     if (!inherits(mark, "ggalign_mark_draw")) {
         cli_abort("{.arg mark} must be a {.fn mark_draw} object")
     }
     reorder <- check_reorder(reorder)
+    assert_obs_size(obs_size)
     assert_active(active)
     active <- update_active(active, new_active(use = TRUE))
     assert_bool(group1, allow_null = TRUE)
@@ -73,7 +76,7 @@ ggmark <- function(mark, data = waiver(), mapping = aes(), ...,
         params = list2(...), # used by AlignGg
         mark = mark, # used by MarkGg
         group1 = group1, group2 = group2,
-        reorder = reorder,
+        reorder = reorder, obs_size = obs_size,
 
         # slot
         plot = ggplot(mapping = mapping),

R/link.R

@@ -217,6 +217,7 @@ makeContent.ggalignLinkTree <- function(x) {
     direction <- .subset2(x, "direction")
     link_index_list <- .subset2(x, "link_index")
     data_index_list <- .subset2(x, "data_index")
+    obs_size <- .subset2(x, "obs_size")
 
     # prepare output for current for loop
     coords <- vector("list", 2L)
@@ -252,31 +253,39 @@ makeContent.ggalignLinkTree <- function(x) {
             spacing <- convertHeight(spacing, "mm", valueOnly = TRUE)
             spacing <- scales::rescale(spacing, c(0, 1), from = c(0, height))
             sizes[is.na(points)] <- spacing
-            cell_height <- (1 - spacing * n_spacing) / sum(!is.na(points))
-            sizes[!is.na(points)] <- cell_height # nobs
+            obs_height <- (1 - spacing * n_spacing) / sum(!is.na(points))
+            sizes[!is.na(points)] <- obs_height # nobs
             yend <- cumsum(sizes)
             link_x <- switch(link,
                 hand1 = 0,
                 hand2 = 1
             )
+            # by default, the height for each observation is `1`,
+            # if we define obs size, we just re-scale it
+            removed <- (1 - obs_size) * obs_height
             link_coord <- data_frame0(
                 x = link_x, xend = link_x,
-                y = yend - sizes, yend = yend
+                y = yend - sizes + removed / 2L,
+                yend = yend - removed / 2L
             )
             link_coord <- vec_slice(link_coord, !is.na(points))
         } else { # the link should be in top or bottom
             spacing <- convertWidth(spacing, "mm", valueOnly = TRUE)
             spacing <- scales::rescale(spacing, c(0, 1), from = c(0, width))
             sizes[is.na(points)] <- spacing
-            cell_width <- (1 - spacing * n_spacing) / sum(!is.na(points))
-            sizes[!is.na(points)] <- cell_width
+            obs_width <- (1 - spacing * n_spacing) / sum(!is.na(points))
+            sizes[!is.na(points)] <- obs_width
             xend <- cumsum(sizes)
             link_y <- switch(link,
                 hand1 = 1,
                 hand2 = 0
             )
+            # by default, the width for each observation is `1`,
+            # if we define obs size, we just re-scale it
+            removed <- (1 - obs_size) * obs_width
             link_coord <- data_frame0(
-                x = xend - sizes, xend = xend,
+                x = xend - sizes + removed / 2L,
+                xend = xend - removed / 2L,
                 y = link_y, yend = link_y
             )
             link_coord <- vec_slice(link_coord, !is.na(points))

R/mark.R

@@ -368,6 +368,7 @@ makeContent.ggalignMarkGtable <- function(x) {
     direction <- .subset2(data, "direction")
     link_index_list <- .subset2(data, "link_index")
     data_index_list <- .subset2(data, "data_index")
+    obs_size <- .subset2(data, "obs_size")
 
     # prepare output for current for loop
     coords <- vector("list", 2L)
@@ -403,16 +404,20 @@ makeContent.ggalignMarkGtable <- function(x) {
             spacing <- convertHeight(spacing, "mm", valueOnly = TRUE)
             spacing <- scales::rescale(spacing, c(0, 1), from = c(0, height))
             sizes[is.na(points)] <- spacing
-            cell_height <- (1 - spacing * n_spacing) / sum(!is.na(points))
-            sizes[!is.na(points)] <- cell_height # nobs
+            obs_height <- (1 - spacing * n_spacing) / sum(!is.na(points))
+            sizes[!is.na(points)] <- obs_height # nobs
             yend <- cumsum(sizes)
             link_x <- switch(link,
                 hand1 = 0,
                 hand2 = 1
             )
+            # by default, the height for each observation is `1`,
+            # if we define obs size, we just re-scale it
+            removed <- (1 - obs_size) * obs_height
             link_coord <- data_frame0(
                 x = link_x, xend = link_x,
-                y = yend - sizes, yend = yend
+                y = yend - sizes + removed / 2L,
+                yend = yend - removed / 2L
             )
             link_coord <- vec_slice(link_coord, !is.na(points))
 
@@ -445,15 +450,19 @@ makeContent.ggalignMarkGtable <- function(x) {
             spacing <- convertWidth(spacing, "mm", valueOnly = TRUE)
             spacing <- scales::rescale(spacing, c(0, 1), from = c(0, width))
             sizes[is.na(points)] <- spacing
-            cell_width <- (1 - spacing * n_spacing) / sum(!is.na(points))
-            sizes[!is.na(points)] <- cell_width
+            obs_width <- (1 - spacing * n_spacing) / sum(!is.na(points))
+            sizes[!is.na(points)] <- obs_width
             xend <- cumsum(sizes)
             link_y <- switch(link,
                 hand1 = 1,
                 hand2 = 0
             )
+            # by default, the width for each observation is `1`,
+            # if we define obs size, we just re-scale it
+            removed <- (1 - obs_size) * obs_width
             link_coord <- data_frame0(
-                x = xend - sizes, xend = xend,
+                x = xend - sizes + removed / 2L,
+                xend = xend - removed / 2L,
                 y = link_y, yend = link_y
             )
             link_coord <- vec_slice(link_coord, !is.na(points))

R/utils-assert.R

@@ -223,3 +223,21 @@ assert_active <- function(x, allow_null = TRUE,
         )
     }
 }
+
+assert_obs_size <- function(obs_size, arg = caller_arg(obs_size),
+                            call = caller_call()) {
+    if (.standalone_types_check_assert_call(
+        ffi_standalone_check_number_1.0.7,
+        obs_size,
+        allow_decimal = TRUE,
+        .Machine$double.eps,
+        1,
+        FALSE,
+        FALSE,
+        FALSE
+    ) != 0L) {
+        cli_abort("{.arg {arg}} must be a single number in `(0, 1]`",
+            call = call
+        )
+    }
+}