R/shiny.R

In ggvis: Interactive Grammar of Graphics

#' Connect a ggvis graphic to a shiny app.
#'
#' Embedding ggvis in a shiny app is easy. You need to make a place for it in
#' your \code{ui.r} with \code{ggvisOutput}, and tell your \code{server.r}
#' where to draw it with \code{bind_shiny}. It's easiest to learn by example:
#' there are many shiny apps in \code{demo/apps/} that you can learn from.
#'
#' @section Client-side:
#' In your UI, use \code{ggvisOutput()} in \code{ui.r} to insert an html
#' placeholder for the plot.
#'
#' If you're going to be using interactive controls generated by ggvis,
#' use \code{\link[shiny]{renderUI}()} to add a place holder. By convention,
#' if the id of plot placehold is called "plot", call the controls placeholder
#' "plot_ui".
#'
#' @section Server-side:
#' When you run ggvis plot interactively, it is automatically plotted because
#' it triggers the default print method. In shiny apps, you need to
#' explicitly render the plot to a specific placeholder with
#' \code{bind_shiny}:
#'
#' \code{p \%>\% bind_shiny("plot")}
#'
#' If the plot has controls, and you've reserved space for them in the UI,
#' supply the name of the placeholder as the third argument:
#'
#' \code{p \%>\% bind_shiny("plot", "plot_ui")}
#' @examples
#' ## Run these examples only in interactive R sessions
#' if (interactive()) {
#'
#' # Simplest possible app:
#' library(shiny)
#' runApp(list(
#'   ui = bootstrapPage(
#'     ggvisOutput("p"),
#'     uiOutput("p_ui")
#'   ),
#'   server = function(..., session) {
#'     mtcars %>%
#'       ggvis(~wt, ~mpg) %>%
#'       layer_points() %>%
#'       layer_smooths(span = input_slider(0, 1)) %>%
#'       bind_shiny("p", "p_ui")
#'   }
#' ))
#'
#' }
#' @name shiny-ggvis
NULL

#' @rdname shiny-ggvis
#' @param vis A ggvis object, or a reactive expression that returns a ggvis
#'   object.
#' @param session A Shiny session object.
#' @param ... Other arguments passed to \code{as.vega}.
#' @export
bind_shiny <- function(vis, plot_id, controls_id = NULL, ...,
                       session = shiny::getDefaultReactiveDomain()) {

  validate_plot_id(plot_id)

  if (is.null(session)) {
    stop("bind_shiny() must be run inside a shiny app.", call. = FALSE)
  }

  if (shiny::is.reactive(vis)) {
    visf <- vis
  } else if (is.ggvis(vis)) {
    visf <- function() vis
  } else {
    stop("bind_shiny requires a ggvis object or a reactive expression that returns a ggvis object",
      call. = FALSE)
  }

  r_spec <- shiny::reactive({
    as.vega(visf(), session = session, dynamic = TRUE, ...)
  })

  observe_spec(r_spec, plot_id, session)
  observe_data(r_spec, plot_id, session)
  exec_connectors(r_spec, plot_id, session)

  if (!is.null(controls_id)) {
    bind_shiny_ui(vis, controls_id, session = session)
  }

  vis
}

#' @param controls_id Unique identifier for controls div.
#' @rdname shiny-ggvis
#' @export
bind_shiny_ui <- function(vis, controls_id,
  session = shiny::getDefaultReactiveDomain()) {
  if (is.null(session)) {
    stop("bind_shiny_ui() must be run inside a shiny app.", call. = FALSE)
  }

  if (shiny::is.reactive(vis)) {
    visf <- vis
  } else if (is.ggvis(vis)) {
    visf <- function() vis
  } else {
    stop("bind_shiny_ui requires a ggvis object or a reactive expression that returns a ggvis object",
      call. = FALSE)
  }

  shiny::observe({
    controls <- visf()$controls
    if (empty(controls)) return()

    # Wrap each control in a div, for layout purposes
    divs <- lapply(controls, htmltools::div,  class = "ggvis-input-container")
    session$output[[controls_id]] <- shiny::renderUI(htmltools::tagList(divs))
  })

  vis
}

# Tell an observer to suspend or resume, depending on the hidden state of an
# output object on the client.
sync_with_hidden_state <- function(obs, id, session) {
  force(obs)

  shiny::observe({
    isHidden <- session$clientData[[paste0('output_', id, '_hidden')]]

    if (identical(isHidden, FALSE)) {
      obs$resume()
    } else {
      obs$suspend()
    }
  })
}

# Create an observer for a reactive vega spec
observe_spec <- function(r_spec, id, session) {
  obs <- shiny::observe(suspended = TRUE, {
    session$sendCustomMessage("ggvis_vega_spec", list(
      plotId = id,
      spec = r_spec()
    ))
  })

  sync_with_hidden_state(obs, id, session)
}

# Create observers for the data objects attached to a reactive vega spec
observe_data <- function(r_spec, id, session) {
  # A list for keeping track of each data observer
  data_observers <- list()

  outer_obs <- shiny::observe(suspended = TRUE, {
    # If data_observers list is nonempty, that means there are old observers
    # which need to be suspended before we create new ones. This can happen when
    # the reactive containing the ggvis() call is invalidated.
    for (obs in data_observers) obs$suspend()

    data_table <- c(attr(r_spec(), "data_table", TRUE),
                    attr(r_spec(), "scale_data_table", TRUE))

    # Create observers for each of the data objects
    data_observers <<- lapply(names(data_table), function(data_name) {
      # The data_table list contains named objects. The names are synthetic IDs
      # that are present in the vega spec.

      force(data_name)
      obs <- shiny::observe(suspended = TRUE, {
        data_reactive <- data_table[[data_name]]

        session$sendCustomMessage("ggvis_data", list(
          plotId = id,
          name = data_name,
          value = as.vega(data_reactive(), data_name)
        ))
      })
      sync_with_hidden_state(obs, id, session)

      obs
    })

    # Tell the plot to update _after_ all the data has been sent
    data_observers[[length(data_observers) + 1]] <<- shiny::observe(suspended = TRUE, {
      # Take dependency on all data objects
      for (name in names(data_table)) {
        data_table[[name]]()
      }

      session$sendCustomMessage("ggvis_command", list(
        plotId = id,
        command = "update"
      ))
    }, priority = -1)
    sync_with_hidden_state(data_observers[[length(data_observers)]], id, session)
  })

  sync_with_hidden_state(outer_obs, id, session)
}

# Run the connector functions
exec_connectors <- function(r_spec, plot_id, session) {
  connectors <- shiny::isolate(attr(r_spec(), "connectors", TRUE))

  lapply(connectors, function(connect) {
    if (!is.null(connect)) {
      connect(session, plot_id)
    }
  })
}

validate_plot_id <- function(id) {
  if (grepl(".", id, fixed = TRUE)) {
    stop("Plot ID '", id, "' is not valid. The ID must not contain a dot (.) character.")
  }
}