Add add_annotations() (as well as purrr dependency)

Author: cpsievert

DESCRIPTION

@@ -35,7 +35,8 @@ Imports:
     dplyr,
     tibble,
     hexbin,
-    lazyeval (>= 0.2.0)
+    lazyeval (>= 0.2.0),
+    purrr
 Suggests:
     MASS,
     maps,

NAMESPACE

@@ -58,12 +58,14 @@ S3method(to_basic,default)
 S3method(transmute_,plotly)
 S3method(ungroup,plotly)
 export("%>%")
+export(add_annotations)
 export(add_area)
 export(add_bars)
 export(add_boxplot)
 export(add_choropleth)
 export(add_contour)
 export(add_data)
+export(add_fun)
 export(add_heatmap)
 export(add_histogram)
 export(add_histogram2d)
@@ -184,6 +186,7 @@ importFrom(lazyeval,f_new)
 importFrom(lazyeval,is_formula)
 importFrom(lazyeval,is_lang)
 importFrom(magrittr,"%>%")
+importFrom(purrr,transpose)
 importFrom(stats,complete.cases)
 importFrom(stats,quantile)
 importFrom(stats,setNames)

R/add.R

@@ -479,24 +479,92 @@ special_attrs <- function(trace) {
 # }
 
 
-## ------------------------------------------------------------------------
-## Non-trace addition
-## ------------------------------------------------------------------------
-#
-##' @export
-#add_transform <- function(p, ...) {
-#  stop("not yet implemented")
-#}
-#
-#
-##' @export
-#add_shape <- function(p, ...) {
-#  stop("not yet implemented")
-#}
-#
-##' @export
-#add_annotation <- function(p, ...) {
-#  stop("not yet implemented")
-#}
 
 
+
+#' Apply function to plot, without modifying data
+#' 
+#' Useful when you need two or more layers that apply a summary statistic
+#' to the original data.
+#' 
+#' @param p a plotly object.
+#' @param fun a function. Should take a plotly object as input and return a 
+#' modified plotly object.
+#' @export
+#' @examples
+#' 
+#' txhousing %>% 
+#'   group_by(city) %>%
+#'   plot_ly(x = ~date, y = ~median) %>%
+#'   add_lines(alpha = 0.2, name = "Texan Cities") %>%
+#'   add_fun(function(plot) {
+#'     plot %>% filter(city == "Houston") %>% add_lines(name = "Houston")
+#'   }) %>%
+#'   add_fun(function(plot) {
+#'     plot %>% filter(city == "San Antonio") %>% add_lines(name = "San Antonio")
+#'   })
+#'
+#' plot_ly(mtcars, x = ~wt, y = ~mpg) %>%
+#'   add_markers() %>%
+#'   add_fun(function(p) {
+#'     p %>% slice(which.max(mpg)) %>% 
+#'       add_annotations("Good mileage")
+#'   }) %>%
+#'   add_fun(function(p) {
+#'     p %>% slice(which.min(mpg)) %>% 
+#'       add_annotations(text = "Bad mileage")
+#'   })
+#'
+add_fun <- function(p, fun) {
+  oldDat <- p$x$cur_data
+  p <- fun(p)
+  p$x$cur_data <- oldDat
+  p$x$attrs[length(p$x$attrs)] <- setNames(
+    list(p$x$attrs[[length(p$x$attrs)]]), oldDat
+  )
+  p
+}
+
+
+#' Add an annotation(s) to a plot
+#' 
+#' @param p a plotly object
+#' @param text annotation text (required).
+#' @param ... these arguments are documented at \url{https://plot.ly/r/reference/#layout-annotations}
+#' @param data a data frame.
+#' @author Carson Sievert
+#' @export
+#' @examples
+#' 
+#' # single annotation
+#' plot_ly(mtcars, x = ~wt, y = ~mpg) %>%
+#'   slice(which.max(mpg)) %>%
+#'   annotation(text = "Good mileage")
+#'   
+#' # multiple annotations
+#' plot_ly(mtcars, x = ~wt, y = ~mpg) %>%
+#'   filter(gear == 5) %>%
+#'   annotation("five cylinder", ax = 40) 
+#'   
+
+add_annotations <- function(p, text = NULL, ..., data = NULL) {
+  if (is.null(text)) {
+    stop("Must provide text!", call. = FALSE)
+  }
+  p <- add_data(p, data)
+  attrs <- list(text = text, ...)
+  # x/y/text inherit from plot_ly()
+  for (i in c("x", "y", "text")) {
+    attrs[[i]] <- attrs[[i]] %||% p$x$attrs[[1]][[i]]
+  }
+  if (is.null(attrs[["text"]])) {
+    stop("Must supply text to annotation", call. = FALSE)
+  }
+  attrs <- list(annotations = attrs)
+  # similar to layout()
+  p$x$layoutAttrs <- c(
+    p$x$layoutAttrs %||% list(), 
+    setNames(list(attrs), p$x$cur_data)
+  )
+  p
+}

R/imports.R

@@ -10,6 +10,7 @@
 #' @importFrom htmlwidgets createWidget sizingPolicy saveWidget
 #' @importFrom lazyeval f_eval is_formula all_dots is_lang f_new
 #' @importFrom tibble as_tibble
+#' @importFrom purrr transpose
 NULL
 
 

R/layout.R

@@ -30,6 +30,7 @@ layout.plotly <- function(p, ..., data = NULL) {
   p
 }
 
+
 #' Set the default configuration for plotly
 #' 
 #' @param p a plotly object

R/plotly_build.R

@@ -32,19 +32,40 @@ plotly_build.gg <- function(p) {
 #' @export
 plotly_build.plotly <- function(p) {
 
+  # make this plot retrievable
+  set_last_plot(p)
+  
   layouts <- Map(function(x, y) {
 
     d <- plotly_data(p, y)
     x <- rapply(x, eval_attr, data = d, how = "list")
+    
+    # if an annotation attribute is an array, expand into multiple annotations 
+    nAnnotations <- max(lengths(x$annotations) %||% 0)
+    x$annotations <- purrr::transpose(lapply(x$annotations, function(x) {
+      as.list(rep(x, length.out = nAnnotations))
+    }))
+    
     x[lengths(x) > 0]
 
   }, p$x$layoutAttrs, names2(p$x$layoutAttrs))
 
-  # get rid of the data -> layout mapping and merge all the layouts
-  # into a single layout (more recent layouts will override older ones)
+  # get rid of the data -> layout mapping 
   p$x$layoutAttrs <- NULL
+  
+  # accumulate, rather than override, annotations.
+  annotations <- Reduce(c, c(
+    if (is.null(names(p$x$layout$annotations))) p$x$layout$annotations else list(p$x$layout$annotations),
+    compact(lapply(layouts, "[", "annotations"))
+  ))
+  # annotations shouldn't have names
+  annotations <- setNames(annotations[[1]], NULL)
+  
+  # merge layouts into a single layout (more recent layouts will override older ones)
   p$x$layout <- modify_list(p$x$layout, Reduce(modify_list, layouts))
-
+  p$x$layout$annotations <- annotations
+  
+  
   # If type was not specified in plot_ly(), it doesn't create a trace unless
   # there are no other traces
   if (is.null(p$x$attrs[[1]][["type"]])) {
@@ -269,8 +290,6 @@ plotly_build.plotly <- function(p) {
   p <- verify_hovermode(p)
   # try to convert to webgl if toWebGl was used
   p <- verify_webgl(p)
-  # make this plot retrievable
-  set_last_plot(p)
   p
 }