Initial support for linked views and animation

NAMESPACE

@@ -82,6 +82,9 @@ export(add_segments)
 export(add_surface)
 export(add_text)
 export(add_trace)
+export(animationButton)
+export(animationOpts)
+export(animationSlider)
 export(arrange)
 export(arrange_)
 export(as.widget)

R/animate.R

@@ -0,0 +1,215 @@
+#' Animation options
+#' 
+#' @param p a plotly object.
+#' @param frameDuration The duration each frame is shown (in milliseconds).
+#' @param transitionDuration The duration of the transition (in milliseconds).
+#' @param easing The type of transition easing. See the list of options here
+#' \url{https://github.com/plotly/plotly.js/blob/master/src/plots/animation_attributes.js}
+#' @param redraw Trigger a redraw of the plot at completion of the transition?
+#' A redraw may significantly impact performance, but may be necessary to 
+#' update plot attributes that can't be transitioned.
+#' @param mode Describes how a new animate call interacts with currently-running
+#' animations. If `immediate`, current animations are interrupted and
+#' the new animation is started. If `next`, the current frame is allowed
+#' to complete, after which the new animation is started. If `afterall`
+#' all existing frames are animated to completion before the new animation
+#' is started.
+#' @export
+#' @author Carson Sievert
+#' @seealso \code{\link{animationSlider}()}, \code{\link{animationButton}()}
+#' @examples 
+#' 
+#' 
+#' #' # map a 
+#' df <- data.frame(
+#'   x = c(1, 2, 2, 1, 1, 2),
+#'   y = c(1, 2, 2, 1, 1, 2),
+#'   z = c(1, 1, 2, 2, 3, 3)
+#' )
+#' plot_ly(df) %>% 
+#'   add_markers(x = 1.5, y = 1.5) %>%
+#'   add_markers(x = ~x, y = ~y, frame = ~z)
+#' 
+#' # works in subplots
+#' subplot(
+#'   plot_ly(df, x = ~x, y = ~y, frame = ~z),
+#'   plot_ly(df, x = ~x, y = ~y, frame = ~z)
+#' )
+#' 
+#' # set the range in plot_ly()
+#' plot_ly(mtcars, x = ~wt, y = ~mpg, frame = ~cyl) %>%
+#'   layout(
+#'     xaxis = ~list(range = range(wt)), 
+#'     yaxis = ~list(range = range(mpg))
+#'  )
+#'  
+#' # works the same way with ggplotly
+#' 
+#' \dontrun{
+#' data(gapminder, package = "gapminder")
+#' p <- ggplot(gapminder, aes(gdpPercap, lifeExp, size = pop, 
+#'   color = continent, frame = year)) +
+#'   geom_point() +
+#'   scale_x_log10()
+#' ggplotly(p)
+#' 
+#' p2 <- ggplot(gapminder, aes(gdpPercap, lifeExp)) +
+#'   geom_point(aes(size = pop), alpha = 0.5) +
+#'   # animations can be specified on the layer level
+#'   geom_point(aes(size = pop, frame = year), color = "red") +
+#'   scale_x_log10()
+#' ggplotly(p2)
+#' }
+#' 
+animationOpts <- function(p, frameDuration = 500, transitionDuration = 500, 
+                          easing = "cubic-in-out", redraw = FALSE, 
+                          mode = "immediate") {
+  if (frameDuration < 0) {
+    stop("frameDuration must be non-negative.", call. = FALSE)
+  }
+  if (transitionDuration < 0) {
+    stop("frameDuration must be non-negative.", call. = FALSE)
+  }
+  opts <- list(
+    transition = list(
+      duration = transitionDuration,
+      easing = match.arg(easing, easingOpts())
+    ),
+    frame = list(
+      duration = frameDuration,
+      redraw = redraw
+    ),
+    mode = match.arg(mode, c('immediate', 'next', 'afterall'))
+  )
+
+  # build step will ensure we can access the animation frames
+  # (required to fill the steps in correctly)
+  p <- plotly_build(p)
+
+  # overwrite the animation options in the slider/button spec
+  supply_ani_slider(supply_ani_button(p, opts))
+}
+
+#' Hide or customize the animation button
+#' 
+#' @param p a plotly object
+#' @param hide remove the animation slider?
+#' @param ... attributes passed to the sliders object which controls the animation
+#' slider \url{https://github.com/plotly/plotly.js/blob/master/src/components/sliders/attributes.js}
+#' @export
+#' @author Carson Sievert
+#' @seealso \code{\link{animationOpts}()}, \code{\link{animationButton}()}
+#' 
+
+animationSlider <- function(p, hide = FALSE, ...) {
+
+  p <- plotly_build(p)
+  isAniSlider <- vapply(p$x$layout$slider, is_ani_slider, logical(1))
+  if (hide) {
+    p$x$layout$slider[isAniSlider] <- NULL
+    return(p)
+  }
+  p$x$layout$slider[[which(isAniSlider)]] <- modify_list(
+    p$x$layout$slider[[which(isAniSlider)]], list(...)
+  )
+  p
+
+}
+
+#' Hide or customize the animation button
+#' 
+#' @param p a plotly object
+#' @param ... arguments passed to the updatemenus which controls the play/pause
+#' button \url{https://github.com/plotly/plotly.js/blob/master/src/components/updatemenus/attributes.js}
+#' @export
+#' @author Carson Sievert
+#' @seealso \code{\link{animationOpts}()}, \code{\link{animationButton}()}
+#' 
+
+animationButton <- function(p, ...) {
+
+  p <- plotly_build(p)
+  isAniButton <- vapply(p$x$layout$updatemenus, is_ani_button, logical(1))
+  p$x$layout$updatemenus[[which(isAniButton)]] <- modify_list(
+    p$x$layout$updatemenus[[which(isAniButton)]], list(...)
+  )
+  p
+}
+
+
+# supply an animation button if it doesn't exist, 
+# and _replace_ an existing animation button
+supply_ani_button <- function(p, opts = NULL) {
+  nmenus <- length(p$x$layout$updatemenus)
+  isAniButton <- vapply(p$x$layout$updatemenus, is_ani_button, logical(1))
+  idx <- if (sum(isAniButton) == 1) which(isAniButton) else nmenus + 1
+  p$x$layout$updatemenus[[idx]] <- create_ani_button(opts)
+  p
+}
+
+create_ani_button <- function(opts) {
+  button <- list(
+    type = 'buttons',
+    direction = 'right',
+    y = 1,
+    x = 0,
+    yanchor = 'bottom',
+    xanchor = 'left',
+    pad = list(b = 10, l = 10),
+    buttons = list(list(
+      label = 'Play',
+      method = 'animate',
+      args = list(list())
+    ), list(
+      label = 'Pause',
+      method = 'animate',
+      args = list(list(), list(mode = "next"))
+    ))
+  )
+  structure(button, class = "aniButton")
+}
+
+is_ani_button <- function(obj) {
+  class(obj) %in% "aniButton"
+}
+
+# supply an animation slider if it doesn't exist, 
+# and _replace_ an existing animation slider
+supply_ani_slider <- function(p, opts = NULL, ...) {
+  nsliders <- length(p$x$layout$sliders)
+  isAniSlider <- vapply(p$x$layout$sliders, is_ani_slider, logical(1))
+  idx <- if (sum(isAniSlider) == 1) which(isAniSlider) else nsliders + 1
+  p$x$layout$sliders[[idx]] <- create_ani_slider(p$x$frames, opts, ...)
+  p
+}
+
+create_ani_slider <- function(frames, opts = NULL, ...) {
+  steps <- lapply(frames, function(f) {
+    nm <- as.character(f[["name"]])
+    args <- list(list(nm))
+    args[[2]] <- opts
+    list(method = "animate", args = args, label = nm)
+  })
+
+  slider <- list(...)
+  slider$visible <- TRUE
+  slider$steps <- slider[["steps"]] %||% steps
+  slider$pad$t <- slider$pad[["t"]] %||% 40
+  structure(slider, class = "aniSlider")
+}
+
+is_ani_slider <- function(obj) {
+  class(obj) %in% "aniSlider"
+}
+
+
+
+easingOpts <- function() {
+  c('linear', 'quad', 'cubic', 'sin', 'exp', 'circle', 'elastic', 'back', 
+    'bounce', 'linear-in', 'quad-in', 'cubic-in', 'sin-in', 'exp-in', 
+    'circle-in', 'elastic-in', 'back-in', 'bounce-in', 'linear-out', 
+    'quad-out', 'cubic-out', 'sin-out', 'exp-out', 'circle-out', 'elastic-out', 
+    'back-out', 'bounce-out', 'linear-in-out', 'quad-in-out', 'cubic-in-out', 
+    'sin-in-out', 'exp-in-out', 'circle-in-out', 'elastic-in-out', 
+    'back-in-out', 'bounce-in-out') 
+}

R/ggplotly.R

@@ -135,7 +135,6 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all",
   }
   tmpPlotFile <- tempfile(fileext = ".png")
   dev_fun(tmpPlotFile, width = deviceWidth, height = deviceHeight)
-
 
   plot <- ggfun("plot_clone")(p)
   if (length(plot$layers) == 0) {
@@ -336,6 +335,7 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all",
   # show only one legend entry per legendgroup
   grps <- sapply(traces, "[[", "legendgroup")
   traces <- Map(function(x, y) {
+    if (!is.null(x[["frame"]])) return(x)
     x$showlegend <- isTRUE(x$showlegend) && y
     x
   }, traces, !duplicated(grps))

R/layers2traces.R

@@ -100,7 +100,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
     # variables that produce multiple traces and deserve their own legend entries
     split_legend <- paste0(names(discreteScales), "_plotlyDomain")
     # add variable that produce multiple traces, but do _not_ deserve entries
-    split_by <- c(split_legend, "PANEL", split_on(d))
+    split_by <- c(split_legend, "PANEL", "frame", split_on(d))
     # ensure the factor level orders (which determines traces order)
     # matches the order of the domain values
     split_vars <- intersect(split_by, names(d))
@@ -434,6 +434,7 @@ geom2trace.GeomPath <- function(data, params, p) {
     y = data[["y"]],
     text = uniq(data$hovertext),
     key = data$key,
+    frame = data$frame,
     type = "scatter",
     mode = "lines",
     name = if (inherits(data, "GeomSmooth")) "fitted values",
@@ -461,6 +462,7 @@ geom2trace.GeomPoint <- function(data, params, p) {
     y = data[["y"]],
     text = uniq(data$hovertext),
     key = data$key,
+    frame = data$frame,
     type = "scatter",
     mode = "markers",
     marker = list(
@@ -494,6 +496,7 @@ geom2trace.GeomBar <- function(data, params, p) {
     y = data[["y"]],
     text = uniq(data$hovertext),
     key = data$key,
+    frame = data$frame,
     type = "bar",
     marker = list(
       autocolorscale = FALSE,
@@ -518,6 +521,7 @@ geom2trace.GeomPolygon <- function(data, params, p) {
     y = data[["y"]],
     text = uniq(data$hovertext),
     key = data$key,
+    frame = data$frame,
     type = "scatter",
     mode = "lines",
     line = list(
@@ -547,6 +551,7 @@ geom2trace.GeomBoxplot <- function(data, params, p) {
   list(
     x = data[["x"]],
     y = data[["y"]],
+    frame = data$frame,
     type = "box",
     hoverinfo = "y",
     fillcolor = toRGB(
@@ -579,6 +584,7 @@ geom2trace.GeomText <- function(data, params, p) {
     y = data[["y"]],
     text = data$label,
     key = data$key,
+    frame = data$frame,
     textfont = list(
       # TODO: how to translate fontface/family?
       size = aes2plotly(data, params, "size"),
@@ -612,6 +618,7 @@ geom2trace.GeomTile <- function(data, params, p) {
   list(
     x = x,
     y = y,
+    frame = data$frame,
     z = matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), byrow = TRUE),
     text = matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow = TRUE),
     colorscale = setNames(colScale, NULL),
@@ -698,6 +705,7 @@ make_error <- function(data, params, xy = "x") {
     x = data[["x"]],
     y = data[["y"]],
     text = uniq(data$hovertext),
+    frame = data$frame,
     type = "scatter",
     mode = "lines",
     opacity = aes2plotly(data, params, "alpha"),

R/plotly.R

@@ -36,6 +36,8 @@
 #' \code{\link{group_by}()}, but ensures at least one trace for each unique
 #' value. This replaces the functionality of the (now deprecated)
 #' \code{group} argument.
+#' @param frame A formula containing a name or expression. The resulting value 
+#' is used to split data into frames, and then animated.
 #' @param width	Width in pixels (optional, defaults to automatic sizing).
 #' @param height Height in pixels (optional, defaults to automatic sizing).
 #' @param source Only relevant for \link{event_data}.
@@ -89,7 +91,7 @@
 plot_ly <- function(data = data.frame(), ..., type = NULL, 
                     color, colors = NULL, alpha = 1, symbol, symbols = NULL, 
                     size, sizes = c(10, 100), linetype, linetypes = NULL,
-                    split, width = NULL, height = NULL, source = "A") {
+                    split, frame, width = NULL, height = NULL, source = "A") {
   if (!is.data.frame(data)) {
     stop("First argument, `data`, must be a data frame.", call. = FALSE)
   }
@@ -120,6 +122,7 @@ plot_ly <- function(data = data.frame(), ..., type = NULL,
   attrs$linetype <- if (!missing(linetype)) linetype
   attrs$size <- if (!missing(size)) size
   attrs$split <- if (!missing(split)) split
+  attrs$frame <- if (!missing(frame)) frame
 
   attrs$colors <- colors
   attrs$alpha <- alpha