diff --git a/DESCRIPTION b/DESCRIPTION index 7ced4c7..465da6b 100644 --- a/DESCRIPTION +++ b/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' diff --git a/NAMESPACE b/NAMESPACE index e65a24a..796555d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(draw) export(gganno) +export(ggfit_panel) export(ggheat) export(gpar) export(ht_opt) diff --git a/R/ggfit-panel.R b/R/ggfit-panel.R new file mode 100644 index 0000000..85e2b03 --- /dev/null +++ b/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() + } +} diff --git a/R/legend.R b/R/legend.R index f2f37af..4b12db9 100644 --- a/R/legend.R +++ b/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( diff --git a/R/prepare.R b/R/prepare.R index ce2e74f..a62eb0a 100644 --- a/R/prepare.R +++ b/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")) { diff --git a/R/utils-grid.R b/R/utils-grid.R index 8d9cc54..d26da1e 100644 --- a/R/utils-grid.R +++ b/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] diff --git a/man/ggfit_panel.Rd b/man/ggfit_panel.Rd new file mode 100644 index 0000000..13ef6ac --- /dev/null +++ b/man/ggfit_panel.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ggfit-panel.R +\name{ggfit_panel} +\alias{ggfit_panel} +\title{Fit ggplot2 panel in a viewport} +\usage{ +ggfit_panel( + gg, + vp = NULL, + sides = c("b", "t", "l", "r"), + elements = c("axis", "lab", "guide"), + gt = NULL +) +} +\arguments{ +\item{gg}{A \link[ggplot2:ggplot]{ggplot2} object.} + +\item{vp}{A \link[grid:viewport]{viewport} object.} + +\item{sides}{Which side to draw besides the panel elements. If \code{NULL}, will +draw panel only.} + +\item{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.} + +\item{gt}{A \link[ggplot2:ggplotGrob]{gtable} object.} +} +\value{ +Draw ggplot object by fitting exactly the panel to a viewport. +} +\description{ +Fit ggplot2 panel in 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) +}