add function ggfit

DESCRIPTION

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

NAMESPACE

@@ -2,7 +2,9 @@
 
 export(draw)
 export(gganno)
+export(ggfit)
 export(ggfit_panel)
+export(ggfit_plot)
 export(ggheat)
 export(gpar)
 export(ht_opt)

R/gganno.R

@@ -324,7 +324,7 @@ draw_gganno <- function(anno, order_list, heat_matrix, id) {
             pattern <- paste0(pattern, collapse = "|")
         }
         vp_gt <- gt_trim_zero_grob(gtable::gtable_filter(gt, pattern))
-        fit_panel(vp_gt, vp = vp)
+        .ggfit_panel(vp_gt, vp = vp)
     }
     list(legend = legend_from_gtable(gt), draw_fn = draw_fn)
 }

R/ggfit-.R

@@ -0,0 +1,56 @@
+#' Fit ggplot2 panel or plot in a viewport
+#'
+#' @param gg A [ggplot2][ggplot2::ggplot] object.
+#' @param align A string indicates how to align the `viewport`, "panel" or
+#' "plot".
+#' @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.
+#' - align = "panel": Draw ggplot object by fitting exactly the panel to `vp`.
+#' - align = "plot": Draw ggplot object in `vp`.
+#' @examples
+#' p <- ggplot(data.frame(x = 0:10, y = 0:10), aes(x, y)) +
+#'     geom_point()
+#' outerBox <- viewport(width = unit(125, "mm"), height = unit(150, "mm"))
+#' innerBox <- viewport(
+#'     x = unit(0.5, "npc"), y = unit(0.6, "npc"),
+#'     width = unit(60, "mm"), height = unit(70, "mm"), angle = -30
+#' )
+#'
+#' # ggfit_panel ------------
+#' grid.newpage()
+#' pushViewport(outerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA))
+#'
+#' pushViewport(innerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA, lwd = 2))
+#' ggfit(p, "panel")
+#'
+#' # ggfit_plot -------------
+#' grid.newpage()
+#' pushViewport(outerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA))
+#'
+#' pushViewport(innerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA, lwd = 2))
+#' ggfit(p, "plot")
+#' @seealso
+#' - [ggfit_panel]
+#' - [ggfit_plot]
+#' @export
+ggfit <- function(gg, align = "panel", vp = NULL,
+                  sides = c("b", "t", "l", "r"),
+                  elements = c("axis", "lab", "guide"),
+                  gt = NULL) {
+    align <- match.arg(align, c("panel", "plot"))
+    if (align == "panel") {
+        ggfit_panel(gg, vp, sides = sides, elements = elements, gt = gt)
+    } else {
+        ggfit_plot(gg, vp, sides = sides, elements = elements, gt = gt)
+    }
+}

R/ggfit-panel.R

@@ -1,13 +1,6 @@
 #' 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.
+#' @inheritParams ggfit
+#' @return Draw ggplot object by fitting exactly the panel to `vp`.
 #' @examples
 #' p <- ggplot(data.frame(x = 0:10, y = 0:10), aes(x, y)) +
 #'     geom_point()
@@ -36,48 +29,27 @@ ggfit_panel <- function(gg, vp = NULL,
     } else {
         stopifnot(gtable::is.gtable(gt))
     }
+    if (!is.null(vp)) stopifnot(inherits(vp, "viewport"))
     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)
+    .ggfit_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")) {
+.ggfit_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()
+    draw_grob(vp, gtable::gtable_filter(gt, "panel"))
     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 = "|")
+        pattern <- paste(ggpatterns(s, side_element), collapse = "|")
         if (!length(pattern)) next
         gt_elements <- gtable::gtable_filter(gt, pattern)
         if (!length(gt_elements)) next
@@ -105,13 +77,6 @@ fit_panel <- function(gt, vp = NULL,
             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()
+        draw_grob(grid::viewport(x, y, width = w, height = h), gt_elements)
     }
 }

R/ggfit-plot.R

@@ -0,0 +1,76 @@
+#' Fit ggplot2 in a viewport
+#' @inheritParams ggfit
+#' @return Draw ggplot object in `vp`.
+#' @examples
+#' p <- ggplot(data.frame(x = 0:10, y = 0:10), aes(x, y)) +
+#'     geom_point()
+#' outerBox <- viewport(width = unit(125, "mm"), height = unit(150, "mm"))
+#' innerBox <- viewport(
+#'     x = unit(0.5, "npc"), y = unit(0.6, "npc"),
+#'     width = unit(60, "mm"), height = unit(70, "mm"), angle = -30
+#' )
+#'
+#' grid.newpage()
+#' pushViewport(outerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA))
+#'
+#' pushViewport(innerBox)
+#' grid.rect(gp = gpar(col = "red", fill = NA, lwd = 2))
+#' ggfit_plot(p)
+#' @export
+ggfit_plot <- function(gg, vp = NULL,
+                       sides = c("b", "t", "l", "r"),
+                       elements = c("axis", "lab", "guide"),
+                       gt = NULL) {
+    if (is.null(gt)) {
+        stopifnot(ggplot2::is.ggplot(gg))
+        gt <- ggplot2::ggplotGrob(gg)
+    } else {
+        stopifnot(gtable::is.gtable(gt))
+    }
+    if (!is.null(vp)) stopifnot(inherits(vp, "viewport"))
+    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")
+    }
+    .ggfit_plot(gt, vp, sides, elements)
+}
+
+.ggfit_plot <- function(gt, vp = NULL,
+                        sides = c("b", "t", "l", "r"),
+                        elements = c("axis", "lab", "guide")) {
+    if (is.null(vp)) vp <- grid::viewport()
+    patterns <- c("panel")
+    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)
+        patterns <- c(patterns, ggpatterns(s, side_element))
+    }
+    draw_grob(vp, gtable::gtable_filter(gt, paste(patterns, collapse = "|")))
+}
+
+ggpatterns <- function(side, element) {
+    if (any(element == "lab")) {
+        lab <- paste("lab", side, sep = "-")
+    } else {
+        lab <- NULL
+    }
+    if (any(element == "axis")) {
+        axis <- paste("axis", side, sep = "-")
+    } else {
+        axis <- NULL
+    }
+    if (any(element == "guide")) {
+        guide <- paste("guide-box", switch(side,
+            l = "left",
+            r = "right",
+            b = "bottom",
+            t = "top"
+        ), sep = "-")
+    } else {
+        guide <- NULL
+    }
+    c(lab, axis, guide)
+}

R/prepare.R

@@ -172,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, sides = NULL)
+            .ggfit_panel(vp_gt, sides = NULL)
         } else {
             vp_gt <- gt_trim_zero_grob(gt)
-            fit_panel(vp_gt, sides = NULL)
+            .ggfit_panel(vp_gt, sides = NULL)
         }
     }
     if (!is.null(object@ggfn) || !identical(rect_gp$type, "none")) {

R/utils-grid.R

@@ -30,6 +30,12 @@ recycle_gp <- function(gp, n) {
     gp
 }
 
+draw_grob <- function(vp, grob) {
+    grid::pushViewport(vp)
+    on.exit(grid::popViewport())
+    grid::grid.draw(grob)
+}
+
 grid_vp_size <- function() {
     current_vp <- grid::current.viewport()$name
     if (current_vp == "ROOT") {