add function ggfit_panel

DESCRIPTION

@@ -31,6 +31,7 @@ Collate:
     'eheat-package.R'
     'ggheat.R'
     'gganno.R'
+    'ggfit-panel.R'
     'import-standalone-assert.R'
     'import-standalone-cli.R'
     'import-standalone-obj-type.R'

NAMESPACE

@@ -2,6 +2,7 @@
 
 export(draw)
 export(gganno)
+export(ggfit_panel)
 export(ggheat)
 export(gpar)
 export(ht_opt)

R/ggfit-panel.R

@@ -0,0 +1,117 @@
+#' Fit ggplot2 panel in a viewport
+#' @param gg A [ggplot2][ggplot2::ggplot] object.
+#' @param vp A [viewport][grid::viewport] object.
+#' @param sides Which side to draw besides the panel elements. If `NULL`, will
+#' draw panel only.
+#' @param elements Ggplot elements to draw, can be a list of a character to
+#' specify elements for each side separately. Valid elements are "axis", "lab",
+#' "guide". Other elements will be ignored.
+#' @param gt A [gtable][ggplot2::ggplotGrob] object.
+#' @return Draw ggplot object by fitting exactly the panel to a viewport.
+#' @examples
+#' p <- ggplot(data.frame(x = 0:10, y = 0:10), aes(x, y)) +
+#'     geom_point()
+#' grid.newpage()
+#' outerBox <- viewport(width = unit(125, "mm"), height = unit(150, "mm"))
+#' pushViewport(outerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA))
+#' innerBox <- viewport(
+#'     x = unit(0.5, "npc"), y = unit(0.6, "npc"),
+#'     width = unit(60, "mm"), height = unit(70, "mm"), angle = -30
+#' )
+#' pushViewport(innerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA, lwd = 2))
+#' ggfit_panel(p)
+#' @export
+ggfit_panel <- function(gg, vp = NULL,
+                        sides = c("b", "t", "l", "r"),
+                        elements = c("axis", "lab", "guide"),
+                        gt = NULL) {
+    # gt <- egg::set_panel_size(
+    #     gg, width = unit(1, "npc"), height = unit(1, "npc")
+    # )
+    if (is.null(gt)) {
+        stopifnot(ggplot2::is.ggplot(gg))
+        gt <- ggplot2::ggplotGrob(gg)
+    } else {
+        stopifnot(gtable::is.gtable(gt))
+    }
+    stopifnot(all(sides %in% c("b", "t", "l", "r")))
+    if (!is.character(elements) && !is.list(elements)) {
+        stop("elements must be a character or a list of character")
+    }
+    fit_panel(gt, vp, sides, elements)
+}
+
+# source by Sandy Muspratt from: https://stackoverflow.com/questions/29535760/fit-ggplot-exactly-to-viewport-size
+fit_panel <- function(gt, vp = NULL,
+                      sides = c("b", "t", "l", "r"),
+                      elements = c("axis", "lab", "guide")) {
+    if (is.null(vp)) vp <- grid::viewport()
+    grid::pushViewport(vp)
+    grid::grid.draw(gtable::gtable_filter(gt, "panel"))
+    grid::popViewport()
+    if (!length(sides)) return(NULL) # styler: off
+    if (is.character(elements)) elements <- list(elements)
+    elements <- rep_len(elements, length(sides))
+    for (i in seq_along(sides)) {
+        s <- .subset(sides, i)
+        side_element <- .subset2(elements, i)
+        if (any(side_element == "lab")) {
+            lab <- paste("lab", s, sep = "-")
+        } else {
+            lab <- NULL
+        }
+        if (any(side_element == "axis")) {
+            axis <- paste("axis", s, sep = "-")
+        } else {
+            axis <- NULL
+        }
+        if (any(side_element == "guide")) {
+            guide <- paste("guide-box", switch(s,
+                l = "left",
+                r = "right",
+                b = "bottom",
+                t = "top"
+            ), sep = "-")
+        } else {
+            guide <- NULL
+        }
+        pattern <- paste(c(lab, axis, guide), collapse = "|")
+        if (!length(pattern)) next
+        gt_elements <- gtable::gtable_filter(gt, pattern)
+        if (!length(gt_elements)) next
+        w <- switch(s,
+            l = ,
+            r = grid::convertX(gtable::gtable_width(gt_elements), "mm"),
+            b = ,
+            t = grid::unit(1, "npc")
+        )
+        h <- switch(s,
+            l = ,
+            r = grid::unit(1, "npc"),
+            b = ,
+            t = grid::convertY(gtable::gtable_height(gt_elements), "mm")
+        )
+        x <- switch(s,
+            l = grid::unit(0, "npc") - .5 * w,
+            r = grid::unit(1, "npc") + .5 * w,
+            b = ,
+            t = grid::unit(0.5, "npc")
+        )
+        y <- switch(s,
+            l = ,
+            r = grid::unit(0.5, "npc"),
+            b = grid::unit(0, "npc") - .5 * h,
+            t = grid::unit(1, "npc") + .5 * h
+        )
+        grid::pushViewport(grid::viewport(
+            x = x,
+            y = y,
+            width = w,
+            height = h
+        ))
+        grid::grid.draw(gt_elements)
+        grid::popViewport()
+    }
+}

R/legend.R

@@ -19,6 +19,7 @@ legend_from_gtable <- function(gt, direction = NULL) {
     outs <- lapply(guides$grobs, function(x) {
         if (grid::is.grob(x) && inherits(x, "zeroGrob")) return(NULL) # styler: off
         guide <- gtable::gtable_filter(x, "guides")
+        if (!length(guide)) return(NULL) # styler: off
         attr(guide, "width") <- gtable::gtable_width(guide)
         attr(guide, "height") <- gtable::gtable_height(guide)
         methods::new(

R/prepare.R

@@ -163,7 +163,6 @@ prepare_ggheat <- function(object) {
         # https://github.com/jokergoo/ComplexHeatmap/blob/master/R/Heatmap-draw_component.R
         # trace back into `draw_heatmap_body()`
         draw_body_env <- parent.frame()
-        vp <- grid::viewport()
         if (with_slice) {
             # we can also use grid::current.viewport()
             # and parse name to get kr or kc
@@ -173,10 +172,10 @@ prepare_ggheat <- function(object) {
             kc <- draw_body_env$kc
             pattern <- sprintf("panel-%d-%d", kr, kc)
             vp_gt <- gt_trim_zero_grob(gtable::gtable_filter(gt, pattern))
-            fit_panel(vp_gt, vp = vp, elements = NULL)
+            fit_panel(vp_gt, sides = NULL)
         } else {
             vp_gt <- gt_trim_zero_grob(gt)
-            fit_panel(vp_gt, vp = vp, elements = NULL)
+            fit_panel(vp_gt, sides = NULL)
         }
     }
     if (!is.null(object@ggfn) || !identical(rect_gp$type, "none")) {

R/utils-grid.R

@@ -44,101 +44,6 @@ grid_vp_size <- function() {
     }
 }
 
-# https://stackoverflow.com/questions/29535760/fit-ggplot-exactly-to-viewport-size
-fit_panel <- function(gt, vp, elements = c("b", "t", "l", "r")) {
-    # Convert the plot to a grob
-    # gt <- ggplot2::ggplotGrob(ggplot)
-
-    # Extract panel, axes and axis labels
-    panel <- gtable::gtable_filter(gt, "panel")
-    # panel <- egg::set_panel_size(
-    #     ggplot, width = unit(1, "npc"), height = unit(1, "npc")
-    # )
-    grid::pushViewport(vp)
-    grid::grid.draw(panel)
-    grid::popViewport()
-
-    if (any("l" == elements)) {
-        # Put labels and axes together
-        # Viewport for left axis and label
-        lab_l <- gtable::gtable_filter(gt, "ylab-l")
-        axis_l <- gtable::gtable_filter(gt, "axis-l")
-        left <- gt_bind(cbind, lab_l, axis_l)
-
-        if (length(left)) {
-            # Get their width
-            w <- grid::convertX(sum(left$widths), "mm")
-            vp_left <- grid::viewport(
-                x = unit(0, "npc") - .5 * w,
-                y = unit(0.5, "npc"),
-                width = w,
-                height = unit(1, "npc")
-            )
-            grid::pushViewport(vp_left)
-            grid::grid.draw(left)
-            grid::popViewport()
-        }
-    }
-
-    if (any("r" == elements)) {
-        # Viewport for right axis and label
-        lab_r <- gtable::gtable_filter(gt, "ylab-r")
-        axis_r <- gtable::gtable_filter(gt, "axis-r")
-        right <- gt_bind(cbind, axis_r, lab_r)
-        if (length(right)) {
-            # Get their width
-            w <- grid::convertX(sum(right$widths), "mm")
-            vp_right <- grid::viewport(
-                x = unit(1, "npc") + .5 * w,
-                y = unit(0.5, "npc"),
-                width = w,
-                height = unit(1, "npc")
-            )
-            grid::pushViewport(vp_right)
-            grid::grid.draw(right)
-            grid::popViewport()
-        }
-    }
-
-    if (any("b" == elements)) {
-        # Viewport for bottom axis and label
-        axis_b <- gtable::gtable_filter(gt, "axis-b")
-        lab_b <- gtable::gtable_filter(gt, "xlab-b")
-        bottom <- gt_bind(rbind, axis_b, lab_b)
-        if (length(bottom)) {
-            # Get their width / height
-            h <- grid::convertX(sum(bottom$heights), "mm")
-            vp_bottom <- grid::viewport(
-                x = unit(0.5, "npc"),
-                y = unit(0, "npc") - .5 * h,
-                width = unit(1, "npc"), height = h
-            )
-            grid::pushViewport(vp_bottom)
-            grid::grid.draw(bottom)
-            grid::popViewport()
-        }
-    }
-
-    if (any("t" == elements)) {
-        # Viewport for top axis and label
-        axis_t <- gtable::gtable_filter(gt, "axis-t")
-        lab_t <- gtable::gtable_filter(gt, "xlab-t")
-        top <- gt_bind(rbind, lab_t, axis_t)
-        if (length(top)) {
-            # Get their width / height
-            h <- grid::convertX(sum(top$heights), "mm")
-            vp_top <- grid::viewport(
-                x = unit(0.5, "npc"),
-                y = unit(1, "npc") + .5 * h,
-                width = unit(1, "npc"), height = h
-            )
-            grid::pushViewport(vp_top)
-            grid::grid.draw(top)
-            grid::popViewport()
-        }
-    }
-}
-
 gt_bind <- function(fn, ...) {
     dots <- list(...)
     dots <- dots[lengths(dots) > 0L]