#' Plot Output
#'
#' Renders a reactive plot that is suitable for assigning to an \code{output}
#' slot.
#'
#' The corresponding HTML output tag should be \code{div} or \code{img} and have
#' the CSS class name \code{shiny-plot-output}.
#'
#' @seealso For the corresponding client-side output function, and example
#'   usage, see \code{\link{plotOutput}}. For more details on how the plots are
#'   generated, and how to control the output, see \code{\link{plotPNG}}.
#'
#' @param expr An expression that generates a plot.
#' @param width,height The width/height of the rendered plot, in pixels; or
#'   \code{'auto'} to use the \code{offsetWidth}/\code{offsetHeight} of the HTML
#'   element that is bound to this plot. You can also pass in a function that
#'   returns the width/height in pixels or \code{'auto'}; in the body of the
#'   function you may reference reactive values and functions. When rendering an
#'   inline plot, you must provide numeric values (in pixels) to both
#'   \code{width} and \code{height}.
#' @param res Resolution of resulting plot, in pixels per inch. This value is
#'   passed to \code{\link{png}}. Note that this affects the resolution of PNG
#'   rendering in R; it won't change the actual ppi of the browser.
#' @param ... Arguments to be passed through to \code{\link[grDevices]{png}}.
#'   These can be used to set the width, height, background color, etc.
#' @param env The environment in which to evaluate \code{expr}.
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#'   is useful if you want to save an expression in a variable.
#' @param func A function that generates a plot (deprecated; use \code{expr}
#'   instead).
#'
#' @export
renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
                       env=parent.frame(), quoted=FALSE, func=NULL) {
  if (!is.null(func)) {
    shinyDeprecated(msg="renderPlot: argument 'func' is deprecated. Please use 'expr' instead.")
  } else {
    installExprFunction(expr, "func", env, quoted)
  }

  args <- list(...)

  if (is.function(width))
    widthWrapper <- reactive({ width() })
  else
    widthWrapper <- NULL

  if (is.function(height))
    heightWrapper <- reactive({ height() })
  else
    heightWrapper <- NULL

  # If renderPlot isn't going to adapt to the height of the div, then the
  # div needs to adapt to the height of renderPlot. By default, plotOutput
  # sets the height to 400px, so to make it adapt we need to override it
  # with NULL.
  outputFunc <- plotOutput
  if (!identical(height, 'auto')) formals(outputFunc)['height'] <- list(NULL)

  return(markRenderFunction(outputFunc, function(shinysession, name, ...) {
    if (!is.null(widthWrapper))
      width <- widthWrapper()
    if (!is.null(heightWrapper))
      height <- heightWrapper()

    # Note that these are reactive calls. A change to the width and height
    # will inherently cause a reactive plot to redraw (unless width and
    # height were explicitly specified).
    prefix <- 'output_'
    if (width == 'auto')
      width <- shinysession$clientData[[paste(prefix, name, '_width', sep='')]];
    if (height == 'auto')
      height <- shinysession$clientData[[paste(prefix, name, '_height', sep='')]];

    if (is.null(width) || is.null(height) || width <= 0 || height <= 0)
      return(NULL)

    # Resolution multiplier
    pixelratio <- shinysession$clientData$pixelratio
    if (is.null(pixelratio))
      pixelratio <- 1

    coordmap <- NULL
    plotFunc <- function() {
      # Actually perform the plotting
      result <- withVisible(func())

      coordmap <<- NULL

      if (result$visible) {
        # Use capture.output to squelch printing to the actual console; we
        # are only interested in plot output

        # Special case for ggplot objects - need to capture coordmap
        if (inherits(result$value, "ggplot")) {
          capture.output(coordmap <<- getGgplotCoordmap(result$value, pixelratio))
        } else {
          capture.output(print(result$value))
        }
      }

      if (is.null(coordmap)) {
        coordmap <<- getPrevPlotCoordmap(width, height)
      }
    }

    outfile <- do.call(plotPNG, c(plotFunc, width=width*pixelratio,
                                  height=height*pixelratio, res=res*pixelratio, args))
    on.exit(unlink(outfile))

    # A list of attributes for the img
    res <- list(
      src=shinysession$fileUrl(name, outfile, contentType='image/png'),
      width=width, height=height, coordmap=coordmap
    )

    # Get error message if present (from attribute on the coordmap)
    error <- attr(coordmap, "error", exact = TRUE)
    if (!is.null(error)) {
      res$error <- error
    }

    res
  }))
}

# The coordmap extraction functions below return something like the examples
# below. For base graphics:
# plot(mtcars$wt, mtcars$mpg)
# str(getPrevPlotCoordmap(400, 300))
# List of 1
#  $ :List of 4
#   ..$ domain :List of 4
#   .. ..$ left  : num 1.36
#   .. ..$ right : num 5.58
#   .. ..$ bottom: num 9.46
#   .. ..$ top   : num 34.8
#   ..$ range  :List of 4
#   .. ..$ left  : num 50.4
#   .. ..$ right : num 373
#   .. ..$ bottom: num 199
#   .. ..$ top   : num 79.6
#   ..$ log    :List of 2
#   .. ..$ x: NULL
#   .. ..$ y: NULL
#   ..$ mapping: Named list()
#
# For ggplot2, it might be something like:
# p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
# str(getGgplotCoordmap(p, 1))
# List of 1
#  $ :List of 10
#   ..$ panel     : int 1
#   ..$ row       : int 1
#   ..$ col       : int 1
#   ..$ panel_vars: Named list()
#   ..$ scale_x   : int 1
#   ..$ scale_y   : int 1
#   ..$ log       :List of 2
#   .. ..$ x: NULL
#   .. ..$ y: NULL
#   ..$ domain    :List of 4
#   .. ..$ left  : num 1.32
#   .. ..$ right : num 5.62
#   .. ..$ bottom: num 9.22
#   .. ..$ top   : num 35.1
#   ..$ mapping   :List of 2
#   .. ..$ x: chr "wt"
#   .. ..$ y: chr "mpg"
#   ..$ range     :List of 4
#   .. ..$ left  : num 40.8
#   .. ..$ right : num 446
#   .. ..$ bottom: num 263
#   .. ..$ top   : num 14.4
#
# With a faceted ggplot2 plot, the outer list contains two objects, each of
# which represents one panel. In this example, there is one panelvar, but there
# can be up to two of them.
# mtc <- mtcars
# mtc$am <- factor(mtc$am)
# p <- ggplot(mtcars, aes(wt, mpg)) + geom_point() + facet_wrap(~ am)
# str(getGgplotCoordmap(p, 1))
# List of 2
#  $ :List of 10
#   ..$ panel     : int 1
#   ..$ row       : int 1
#   ..$ col       : int 1
#   ..$ panel_vars:List of 1
#   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 1
#   ..$ scale_x   : int 1
#   ..$ scale_y   : int 1
#   ..$ log       :List of 2
#   .. ..$ x: NULL
#   .. ..$ y: NULL
#   ..$ domain    :List of 4
#   .. ..$ left  : num 1.32
#   .. ..$ right : num 5.62
#   .. ..$ bottom: num 9.22
#   .. ..$ top   : num 35.1
#   ..$ mapping   :List of 3
#   .. ..$ x        : chr "wt"
#   .. ..$ y        : chr "mpg"
#   .. ..$ panelvar1: chr "am"
#   ..$ range     :List of 4
#   .. ..$ left  : num 45.6
#   .. ..$ right : num 317
#   .. ..$ bottom: num 251
#   .. ..$ top   : num 35.7
#  $ :List of 10
#   ..$ panel     : int 2
#   ..$ row       : int 1
#   ..$ col       : int 2
#   ..$ panel_vars:List of 1
#   .. ..$ panelvar1: Factor w/ 2 levels "0","1": 2
#   ..$ scale_x   : int 1
#   ..$ scale_y   : int 1
#   ..$ log       :List of 2
#   .. ..$ x: NULL
#   .. ..$ y: NULL
#   ..$ domain    :List of 4
#   .. ..$ left  : num 1.32
#   .. ..$ right : num 5.62
#   .. ..$ bottom: num 9.22
#   .. ..$ top   : num 35.1
#   ..$ mapping   :List of 3
#   .. ..$ x        : chr "wt"
#   .. ..$ y        : chr "mpg"
#   .. ..$ panelvar1: chr "am"
#   ..$ range     :List of 4
#   .. ..$ left  : num 322
#   .. ..$ right : num 594
#   .. ..$ bottom: num 251
#   .. ..$ top   : num 35.7


# Get a coordmap for the previous plot made with base graphics.
# Requires width and height of output image, in pixels.
# Must be called before the graphics device is closed.
getPrevPlotCoordmap <- function(width, height) {
  usrCoords <- par('usr')
  usrBounds <- usrCoords
  if (par('xlog')) {
    usrBounds[c(1,2)] <- 10 ^ usrBounds[c(1,2)]
  }
  if (par('ylog')) {
    usrBounds[c(3,4)] <- 10 ^ usrBounds[c(3,4)]
  }

  # Wrapped in double list because other types of plots can have multiple panels.
  list(list(
    # Bounds of the plot area, in data space
    domain = list(
      left = usrCoords[1],
      right = usrCoords[2],
      bottom = usrCoords[3],
      top = usrCoords[4]
    ),
    # The bounds of the plot area, in DOM pixels
    range = list(
      left = grconvertX(usrBounds[1], 'user', 'nfc') * width,
      right = grconvertX(usrBounds[2], 'user', 'nfc') * width,
      bottom = (1-grconvertY(usrBounds[3], 'user', 'nfc')) * height - 1,
      top = (1-grconvertY(usrBounds[4], 'user', 'nfc')) * height - 1
    ),
    log = list(
      x = if (par('xlog')) 10 else NULL,
      y = if (par('ylog')) 10 else NULL
    ),
    # We can't extract the original variable names from a base graphic.
    # `mapping` is an empty _named_ list, so that it is converted to an object
    # (not an array) in JSON.
    mapping = list(x = NULL)[0]
  ))
}

# Print a ggplot object and return a coordmap for it.
getGgplotCoordmap <- function(p, pixelratio) {
  if (!inherits(p, "ggplot"))
    return(NULL)

  # A modified version of print.ggplot which returns the built ggplot object
  # as well as the gtable grob.
  print_ggplot <- function(x) {
    grid::grid.newpage()

    build <- ggplot2::ggplot_build(x)

    gtable <- ggplot2::ggplot_gtable(build)
    grid::grid.draw(gtable)

    list(
      build = build,
      gtable = gtable
    )
  }

  # Given a built ggplot object, return x and y domains (data space coords) for
  # each panel.
  find_panel_info <- function(b) {
    layout <- b$panel$layout
    # Convert factor to numbers
    layout$PANEL <- as.integer(as.character(layout$PANEL))

    # Names of facets
    facet <- b$plot$facet
    facet_vars <- NULL
    if (inherits(facet, "grid")) {
      facet_vars <- vapply(c(facet$cols, facet$rows), as.character, character(1))
    } else if (inherits(facet, "wrap")) {
      facet_vars <- vapply(facet$facets, as.character, character(1))
    }

    # Iterate over each row in the layout data frame
    lapply(seq_len(nrow(layout)), function(i) {
      # Slice out one row
      l <- layout[i, ]

      scale_x <- l$SCALE_X
      scale_y <- l$SCALE_Y

      mapping <- find_plot_mappings(b)

      # For each of the faceting variables, get the value of that variable in
      # the current panel. Default to empty _named_ list so that it's sent as a
      # JSON object, not array.
      panel_vars <- list(a = NULL)[0]
      for (i in seq_along(facet_vars)) {
        var_name <- facet_vars[[i]]
        vname <- paste0("panelvar", i)

        mapping[[vname]] <- var_name
        panel_vars[[vname]] <- l[[var_name]]
      }

      list(
        panel   = l$PANEL,
        row     = l$ROW,
        col     = l$COL,
        panel_vars = panel_vars,
        scale_x = scale_x,
        scale_y = scale_x,
        log     = check_log_scales(b, scale_x, scale_y),
        domain  = find_panel_domain(b, l$PANEL, scale_x, scale_y),
        mapping = mapping
      )
    })
  }

  # Given a single range object (representing the data domain) from a built
  # ggplot object, return the domain.
  find_panel_domain <- function(b, panel_num, scalex_num = 1, scaley_num = 1) {
    range <- b$panel$ranges[[panel_num]]
    res <- list(
      left   = range$x.range[1],
      right  = range$x.range[2],
      bottom = range$y.range[1],
      top    = range$y.range[2]
    )

    # Check for reversed scales
    xscale <- b$panel$x_scales[[scalex_num]]
    yscale <- b$panel$y_scales[[scaley_num]]

    if (!is.null(xscale$trans) && xscale$trans$name == "reverse") {
      res$left  <- -res$left
      res$right <- -res$right
    }
    if (!is.null(yscale$trans) && yscale$trans$name == "reverse") {
      res$top    <- -res$top
      res$bottom <- -res$bottom
    }

    res
  }

  # Given built ggplot object, return object with the log base for x and y if
  # there are log scales or coord transforms.
  check_log_scales <- function(b, scalex_num = 1, scaley_num = 1) {

    # Given a vector of transformation names like c("log-10", "identity"),
    # return the first log base, like 10. If none are present, return NULL.
    extract_log_base <- function(names) {
      names <- names[grepl("^log-", names)]

      if (length(names) == 0)
        return(NULL)

      names <- names[1]

      as.numeric(sub("^log-", "", names))
    }

    # Look for log scales and log coord transforms. People shouldn't use both.
    x_names <- character(0)
    y_names <- character(0)

    # Continuous scales have a trans; discrete ones don't
    if (!is.null(b$panel$x_scales[[scalex_num]]$trans))
      x_names <- b$panel$x_scales[[scalex_num]]$trans$name
    if (!is.null(b$panel$y_scales[[scaley_num]]$trans))
      y_names <- b$panel$y_scales[[scaley_num]]$trans$name

    coords <- b$plot$coordinates
    if (!is.null(coords$trans)) {
      if (!is.null(coords$trans$x))
        x_names <- c(x_names, coords$trans$x$name)
      if (!is.null(coords$trans$y))
        y_names <- c(y_names, coords$trans$y$name)
    }

    # Keep only scale/trans names that start with "log-"
    x_names <- x_names[grepl("^log-", x_names)]
    y_names <- y_names[grepl("^log-", y_names)]

    # Extract the log base from the trans name -- a string like "log-10".
    list(
      x = extract_log_base(x_names),
      y = extract_log_base(y_names)
    )
  }

  # Given a built ggplot object, return a named list of variables mapped to x
  # and y. This function will be called for each panel, but in practice the
  # result is always the same across panels, so we'll cache the result.
  mappings_cache <- NULL
  find_plot_mappings <- function(b) {
    if (!is.null(mappings_cache))
      return(mappings_cache)

    # lapply'ing as.character results in unexpected behavior for expressions
    # like `wt/2`. This works better.
    mappings <- as.list(as.character(b$plot$mapping))

    # If x or y mapping is missing, look in each layer for mappings and return
    # the first one.
    missing_mappings <- setdiff(c("x", "y"), names(mappings))
    if (length(missing_mappings) != 0) {
      # Grab mappings for each layer
      layer_mappings <- lapply(b$plot$layers, function(layer) {
        lapply(layer$mapping, as.character)
      })

      # Get just the first x or y value in the combined list of plot and layer
      # mappings.
      mappings <- c(list(mappings), layer_mappings)
      mappings <- Reduce(x = mappings, init = list(x = NULL, y = NULL),
        function(init, m) {
          if (is.null(init$x) && !is.null(m$x)) init$x <- m$x
          if (is.null(init$y) && !is.null(m$y)) init$y <- m$y
          init
        }
      )
    }

    mappings_cache <<- mappings
    mappings
  }

  # Given a gtable object, return the x and y ranges (in pixel dimensions)
  find_panel_ranges <- function(g, pixelratio) {
    # Given a vector of unit objects, return logical vector indicating which ones
    # are "null" units. These units use the remaining available width/height --
    # that is, the space not occupied by elements that have an absolute size.
    is_null_unit <- function(x) {
      vapply(x, FUN.VALUE = logical(1), function(u) {
        isTRUE(attr(u, "unit", exact = TRUE) == "null")
      })
    }

    # Convert a unit (or vector of units) to a numeric vector of pixel sizes
    h_px <- function(x) as.numeric(grid::convertHeight(x, "native"))
    w_px <- function(x) as.numeric(grid::convertWidth(x, "native"))

    # Given a vector of relative sizes (in grid units), and a function for
    # converting grid units to numeric pixels, return a numeric vector of
    # pixel sizes.
    find_px_sizes <- function(rel_sizes, unit_to_px) {
      # Total pixels (in height or width)
      total_px <- unit_to_px(grid::unit(1, "npc"))
      # Calculate size of all panel(s) together. Panels (and only panels) have
      # null size.
      null_idx <- is_null_unit(rel_sizes)
      # All the absolute heights. At this point, null heights are 0. We need to
      # calculate them separately and add them in later.
      px_sizes <- unit_to_px(rel_sizes)
      # Total size for panels is image size minus absolute (non-panel) elements
      panel_px_total <- total_px - sum(px_sizes)
      # Divide up the total panel size up into the panels (scaled by size)
      panel_sizes_rel <- as.numeric(rel_sizes[null_idx])
      panel_sizes_rel <- panel_sizes_rel / sum(panel_sizes_rel)
      px_sizes[null_idx] <- panel_px_total * panel_sizes_rel
      abs(px_sizes)
    }

    px_heights <- find_px_sizes(g$heights, h_px)
    px_widths <- find_px_sizes(g$widths, w_px)

    # Convert to absolute pixel positions
    x_pos <- cumsum(px_widths)
    y_pos <- cumsum(px_heights)

    # Match up the pixel dimensions to panels
    layout <- g$layout
    # For panels:
    # * For facet_wrap, they'll be named "panel-1", "panel-2", etc.
    # * For no facet or facet_grid, they'll just be named "panel". For
    #   facet_grid, we need to re-order the layout table. Assume that panel
    #   numbers go from left to right, then next row.
    # Assign a number to each panel, corresponding to PANEl in the built ggplot
    # object.
    layout <- layout[grepl("^panel", layout$name), ]
    layout <- layout[order(layout$t, layout$l), ]
    layout$panel <- seq_len(nrow(layout))

    # When using a HiDPI client on a Linux server, the pixel
    # dimensions are doubled, so we have to divide the dimensions by
    # `pixelratio`. When a HiDPI client is used on a Mac server (with
    # the quartz device), the pixel dimensions _aren't_ doubled, even though
    # the image has double size. In the latter case we don't have to scale the
    # numbers down.
    pix_ratio <- 1
    if (!grepl("^quartz", names(dev.cur()))) {
      pix_ratio <- pixelratio
    }

    # Return list of lists, where each inner list has left, right, top, bottom
    # values for a panel
    lapply(seq_len(nrow(layout)), function(i) {
      p <- layout[i, , drop = FALSE]
      list(
        left   = x_pos[p$l - 1] / pix_ratio,
        right  = x_pos[p$r] / pix_ratio,
        bottom = y_pos[p$b] / pix_ratio,
        top    = y_pos[p$t - 1] / pix_ratio
      )
    })
  }


  res <- print_ggplot(p)

  tryCatch({
    # Get info from built ggplot object
    info <- find_panel_info(res$build)

    # Get ranges from gtable - it's possible for this to return more elements than
    # info, because it calculates positions even for panels that aren't present.
    # This can happen with facet_wrap.
    ranges <- find_panel_ranges(res$gtable, pixelratio)

    for (i in seq_along(info)) {
      info[[i]]$range <- ranges[[i]]
    }

    return(info)

  }, error = function(e) {
    # If there was an error extracting info from the ggplot object, just return
    # a list with the error message.
    return(structure(list(), error = e$message))
  })
}