R/as-grob.R

In GuangchuangYu/ggplotify: Convert Plot to 'grob' or 'ggplot' Object

##' convert a plot to grob object
##'
##'
##' @title as.grob
##' @rdname as-grob
##' @param plot base or grid plot, or graphic object generated by ggplot, lattice, etc.
##' @param ... additional parameter, mostly will be ignored.
##' @return grob object
##' @export
##' @examples
##' as.grob(~barplot(1:10))
##' @author Guangchuang Yu
as.grob <- function(plot, ...) {
    UseMethod("as.grob")
}

##' @rdname as-grob
##' @method as.grob aplot
##' @export
as.grob.aplot <- function(plot, ...) {
    aplotGrob <- utils::getFromNamespace("aplotGrob", "aplot")
    aplotGrob(plot)
}

##' @rdname as-grob
##' @method as.grob oncoplot
##' @export
as.grob.oncoplot <- function(plot, ...) {
    oncoplotGrob <- utils::getFromNamespace("oncoplotGrob", "aplot")
    oncoplotGrob(plot)
}

##' @rdname as-grob
##' @method as.grob bbplot
##' @export
as.grob.bbplot <- function(plot, ...) {
    base2grob(~print(plot))
}

##' @rdname as-grob
##' @method as.grob patchwork
##' @export
as.grob.patchwork <- function(plot, ...) {
    patchworkGrob <- utils::getFromNamespace("patchworkGrob", "patchwork")
    patchworkGrob(plot)
}

##' @rdname as-grob
##' @method as.grob gglist
##' @export
as.grob.gglist <- function(plot, ...) {
    gglistGrob <- utils::getFromNamespace("gglistGrob", "aplot")
    gglistGrob(plot)
}

##' @rdname as-grob
##' @method as.grob expression
##' @export
as.grob.expression <- function(plot, ...) {
    p <- tryCatch(base2grob(plot, ...),
                  error = function(e) NULL)

    if (is.null(p)) {
        p <- grid2grob(plot_fun(plot, ...)())
    }

    return(p)
}

##' @rdname as-grob
##' @method as.grob formula
##' @export
as.grob.formula <- as.grob.expression


##' @rdname as-grob
##' @method as.grob function
##' @export
as.grob.function <- as.grob.expression

##' @rdname as-grob
##' @importFrom ggplot2 ggplotGrob
##' @method as.grob ggplot
##' @export
as.grob.ggplot <- function(plot, ...) {
    ggplotGrob(plot)
}

##' @rdname as-grob
##' @importFrom yulab.utils get_fun_from_pkg
##' @method as.grob meme
##' @export
as.grob.meme <- function(plot, ...) {
    memeGrob <- get_fun_from_pkg("meme", "memeGrob")
    memeGrob(plot)
}

##' @rdname as-grob
##' @method as.grob trellis
##' @export
as.grob.trellis <- function(plot, ...) {
    grid2grob(print(plot))
}

##' @rdname as-grob
##' @method as.grob eulergram
##' @importFrom grid grid.draw
##' @export
as.grob.eulergram <- function(plot, ...) {
    grid2grob(grid.draw(plot))
}

## ComplexHeatmap
##' @rdname as-grob
##' @method as.grob Heatmap
##' @export
as.grob.Heatmap <- as.grob.trellis

##' @rdname as-grob
##' @method as.grob upset
##' @export
as.grob.upset <- as.grob.trellis

##' @rdname as-grob
##' @method as.grob pheatmap
##' @export
as.grob.pheatmap <- function(plot, ...) {
    plot$gtable
}

##' @rdname as-grob
##' @usage NULL
##' @method as.grob magick-image
##' @importFrom grid rasterGrob
##' @export
"as.grob.magick-image" <- function(plot, ...) {
    rasterGrob(plot)
}


##' @rdname as-grob
##' @method as.grob grob
##' @export
as.grob.grob <- function(plot, ...) {
    plot
}

##' convert base plot to grob object
##'
##'
##' @title base2grob
##' @param x expression or formula of base plot function call, e.g. expression(pie(1:5)) or ~plot(1:10, 1:10);
##' or a function that plots to an R graphics device when called, e.g. function() plot(sqrt)
##' @param envir environment to search variables
##' @return grob object
##' @importFrom gridGraphics grid.echo
##' @importFrom grid grid.grabExpr
##' @export
##' @examples
##' base2grob(~plot(rnorm(10)))
##' @author Guangchuang Yu
base2grob <- function(x, envir = parent.frame()) {
    old.par=par(no.readonly=TRUE)
    on.exit(suppressWarnings(par(old.par, no.readonly=TRUE)))

    grid2grob(grid.echo(plot_fun(x, envir = envir)))
}

##' convert grid plot to grob object
##'
##'
##' @title grid2grob
##' @param plot_call plot function call
##' @return grob object
##' @export
##' @author Guangchuang Yu
grid2grob <- function(plot_call) {
    grid::grid.grabExpr(plot_call, warn=0)
}