Trellis argument

NAMESPACE

@@ -22,6 +22,7 @@ S3method(groups,plotly)
 S3method(layout,matrix)
 S3method(layout,plotly)
 S3method(mutate_,plotly)
+S3method(plotly_build,built)
 S3method(plotly_build,gg)
 S3method(plotly_build,list)
 S3method(plotly_build,plotly)

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 trellis A formula containing a name or expression. The result is
+#' used as a conditioning variable for generating trellis displays.
 #' @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, trellis, 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$trellis <- if (!missing(trellis)) trellis
 
   attrs$colors <- colors
   attrs$alpha <- alpha

R/plotly_build.R

@@ -30,6 +30,11 @@ plotly_build.gg <- function(p) {
   supply_defaults(p)
 }
 
+#' @export
+plotly_build.built <- function(p) {
+  structure(p, class = setdiff(class(p), "built"))
+}
+
 #' @export
 plotly_build.plotly <- function(p) {
 
@@ -157,14 +162,12 @@ plotly_build.plotly <- function(p) {
     for (i in seq_along(tr)) {
       if (inherits(tr[[i]], "AsIs")) builtData[[i]] <- I(builtData[[i]])
     }
-
     if (NROW(builtData) > 0) {
       # Build the index used to split one "trace" into multiple traces
       isAsIs <- vapply(builtData, function(x) inherits(x, "AsIs"), logical(1))
       isDiscrete <- vapply(builtData, is.discrete, logical(1))
        # note: can only have one linetype per trace
-      isSplit <- names(builtData) %in% "split"
-        names(builtData) %in% "linetype" |
+      isSplit <- names(builtData) %in% c("linetype", "split", "trellis") |
         !isAsIs & isDiscrete & names(builtData) %in% c("symbol", "color")
       if (any(isSplit)) {
         paste2 <- function(x, y) if (identical(x, y)) x else paste(x, y, sep = "<br />")
@@ -226,6 +229,7 @@ plotly_build.plotly <- function(p) {
     if (i == 1) traces[[1]] <- c(traces[[1]], d[scaleAttrs])
   }
 
+
   # insert NAs to differentiate groups
   traces <- lapply(traces, function(x) {
     d <- data.frame(x[names(x) %in% x$.plotlyVariableMapping], stringsAsFactors = FALSE)
@@ -251,7 +255,8 @@ plotly_build.plotly <- function(p) {
   traces <- map_size(traces)
   traces <- map_symbol(traces)
   traces <- map_linetype(traces)
-
+  traces <- map_trellis(traces)
+
   # remove special mapping attributes
   for (i in seq_along(traces)) {
     mappingAttrs <- c(
@@ -321,7 +326,7 @@ plotly_build.plotly <- function(p) {
   p <- verify_hovermode(p)
   # try to convert to webgl if toWebGl was used
   p <- verify_webgl(p)
-  p
+  if (length(missing_anchor_attrs(p$x))) subplot(prefix_class(p, "built")) else p
 }
 
 # ----------------------------------------------------------------
@@ -649,6 +654,26 @@ map_linetype <- function(traces) {
   traces
 }
 
+# map the trellis variable to a sensible trace ID
+map_trellis <- function(traces) {
+  anchors <- c("xaxis" = "x",  "geo" = "geo", "subplot" = "mapbox")
+  domain <- unique(unlist(lapply(traces, "[[", "trellis")))
+  for (i in seq_along(traces)) {
+    if (is.null(traces[[i]][["trellis"]])) next
+    for (j in seq_along(anchors)) {
+      key <- names(anchors)[[j]]
+      if (!has_attr(traces[[i]][["type"]], key)) next
+      range <- paste0(
+        rep(anchors[[j]], length(domain)), sub("^1$", "", seq_along(domain))
+      )
+      map <- setNames(range, domain)
+      traces[[i]][[key]] <- 
+        setNames(map[as.character(traces[[i]][["trellis"]])], NULL)
+    }
+  }
+  traces
+}
+
 
 # break up a single trace into multiple traces according to values stored
 # a particular key name

R/utils.R

@@ -49,7 +49,14 @@ getLevels <- function(x) {
 
 # currently implemented non-positional scales in plot_ly()
 npscales <- function() {
-  c("color", "symbol", "linetype", "size", "split")
+  c("color", "symbol", "linetype", "size", "split", "trellis")
+}
+
+missing_anchor_attrs <- function(p) {
+  layoutAttrs <- c(names(p$layout), c("mapbox", "geo", "xaxis", "yaxis"))
+  xTraceAttrs <- sub("^x", "xaxis", sapply(p$data, function(tr) tr[["subplot"]] %||% tr[["geo"]] %||% tr[["xaxis"]]))
+  yTraceAttrs <- sub("^y", "yaxis", sapply(p$data, function(tr) tr[["subplot"]] %||% tr[["geo"]] %||% tr[["yaxis"]]))
+  setdiff(c(xTraceAttrs, yTraceAttrs), layoutAttrs)
 }
 
 # copied from https://github.com/plotly/plotly.js/blob/master/src/components/color/attributes.js
@@ -110,12 +117,16 @@ is_subplot <- function(p) {
   isTRUE(p$x$subplot)
 }
 
+subplot_ids <- function() {
+  # 3D is not yet working in subplot
+  c("xaxis", "yaxis", "geo", "mapbox")
+}
+
 supply_defaults <- function(p) {
   # no need to supply defaults for subplots
   if (is_subplot(p)) return(p)
   # supply trace anchor defaults
   anchors <- if (is_geo(p)) c("geo" = "geo") else if (is_mapbox(p)) c("subplot" = "mapbox") else c("xaxis" = "x", "yaxis" = "y")
-
   p$x$data <- lapply(p$x$data, function(tr) {
     for (i in seq_along(anchors)) {
       key <- names(anchors)[[i]]