R/raster.R

In hafen/rmote: Serve Graphics over HTTP a from Remote Server

#' Print trellis plot to servr
#'
#' @param x trellis object
#' @param \ldots  additional parameters
#' @import htmltools
#' @importFrom digest digest
#' @export
print.trellis <- function(x, ...) {
  print_graphics(x)
}

#' Print ggplot2 plot to servr
#'
#' @param x ggplot object
#' @param \ldots  additional parameters
#' @export
print.ggplot <- function(x, ...) {
  print_graphics(x)
}

#' Wrap a expression that creates a base R plot as a plot_expression
#'
#' @param x an expression
#' @examples
#' \dontrun{
#' start_rmote(basegraphics = FALSE)
#' plot_expression(expression({
#'   plot(10:1)
#'   abline(0, 1)
#' }))
#' }
#' @export
plot_expression <- function(x) {
  class(x) <- c("plot_expression", class(x))
  x
}

#' Print plot_expression plot to servr
#'
#' @param x plot_expression object
#' @param \ldots  additional parameters
#' @export
print.plot_expression <- function(x, ...) {
  print_graphics(x)
}

print_graphics <- function(x) {

  graphics_opt <- getOption("rmote_graphics", FALSE)

  if (is_rmote_on() && graphics_opt && no_other_devices()) {
    message("serving graphics through rmote")

    output_dir <- file.path(get_server_dir(), "plots")
    if (!file.exists(output_dir))
      dir.create(output_dir, recursive = TRUE)

    opts <- getOption("rmote_device")
    if (is.null(opts)) {
      rmote_device()
      opts <- getOption("rmote_device")
    }

    if (is.null(opts$filename)) {
      plot_base <- digest::digest(x)
    } else {
      plot_base <- opts$filename
    }
    file <- file.path("plots", paste0(plot_base, ".", opts$type))
    ofile <- file.path(output_dir, paste0(plot_base, ".", opts$type))

    cur_type <- opts$type
    if (opts$type == "png") {
      ww <- opts$width
      hh <- opts$height
      if (opts$retina) {
        opts$width <- opts$width * 2
        opts$height <- opts$height * 2
        opts$res <- 150
      }
      html <- tags$html(
        tags$head(tags$title(paste("raster plot:", plot_base))),
        tags$body(tags$img(src = file,
          width = paste0(ww, "'x"), height = paste0(hh, "'x"))))
      opts$type <- NULL
      opts$retina <- NULL
      opts$filename <- ofile
      if (capabilities("cairo"))
        opts$type <- "cairo-png"
      do.call(png, opts)
    } else if (opts$type == "pdf") {
      html <- tags$html(
        tags$head(tags$title(paste("raster plot:", plot_base))),
        tags$body(tags$a(href = file, "pdf", target = "_blank")))
      opts$type <- NULL
      opts$file <- ofile
      do.call(pdf, opts)
    }

    if (inherits(x, c("trellis", "ggplot", "expression"))) {
      if (inherits(x, "trellis"))
        getFromNamespace("print.trellis", "lattice")(x)
      if (inherits(x, "ggplot"))
        getFromNamespace("print.ggplot", "ggplot2")(x)
      if (inherits(x, "expression"))
        eval(x)

      dev.off()

      if (!file.exists(ofile))
        stop("Nothing was plotted...")

      res <- write_html(html)

      # make thumbnail
      if (is_history_on())
        make_raster_thumb(res, cur_type, opts, ofile)

    } else if (inherits(x, "base_graphics")) {
      message("when finished with plot commands, call plot_done()")
      options(rmote_baseplot = list(html = html, ofile = ofile,
        cur_type = cur_type, opts = opts))
    }

    return()
  } else {
    if (inherits(x, "trellis"))
      return(getFromNamespace("print.trellis", "lattice")(x))
    if (inherits(x, "ggplot"))
      return(getFromNamespace("print.ggplot", "ggplot2")(x))
    if (inherits(x, "expression"))
      eval(x)
  }
}

#' Set device parameters for traditional grahpics plot output
#'
#' @param type either "png" or "pdf"
#' @param filename optional name for file (should have no extension and no directories)
#' @param retina if TRUE and type is "png", the png file will be plotted at twice its size and shown at the original size, to look better on high resolution displays
#' @param \ldots parameters passed on to either \code{\link[grDevices]{png}} or \code{\link[grDevices]{pdf}} (such as width, height, etc.)
#' @export
rmote_device <- function(type = c("png", "pdf"), filename = NULL, retina = TRUE, ...) {

  type <- match.arg(type)
  opts <- list(...)
  opts$type <- type
  opts$filename <- filename
  if (type == "png") {
    opts$retina <- retina
    if (is.null(opts$width))
      opts$width <- 480
    if (is.null(opts$height))
      opts$height <- 480
  }

  options(rmote_device = opts)
}

make_raster_thumb <- function(res, cur_type, opts, ofile) {
  message("making thumbnail")
  fbase <- file.path(get_server_dir(), "thumbs")
  if (!file.exists(fbase))
    dir.create(fbase)
  nf <- file.path(fbase, gsub("html$", "png", basename(res)))
  if (cur_type == "pdf") {
    opts <- list(filename = nf, width = 300, height = 150)
    if (capabilities("cairo"))
      opts$type <- "cairo-png"
    do.call(png, opts)
    getFromNamespace("print.trellis", "lattice")(text_plot("pdf file"))
    dev.off()
  } else {
    suppressMessages(make_thumb(ofile, nf, width = opts$width, height = opts$height))
  }
}