Added support for ggplot2's facets.

.travis.yml

@@ -5,6 +5,7 @@ before_script:
 - chmod 755 ./travis-tool.sh
 - ./travis-tool.sh bootstrap
 - ./travis-tool.sh install_deps
- - ./travis-tool.sh install_r RCurl RJSONIO
+ - ./travis-tool.sh install_r RCurl RJSONIO lattice
 notifications:
- slack: ropensci:wh30e1MP9Am3wXb2wJx1ZRFi
+ slack: ropensci:wh30e1MP9Am3wXb2wJx1ZRFi
+

R/ggplotly.R

@@ -6,6 +6,11 @@
 ##' @export
 ##' @return list of geom info.
 ##' @author Toby Dylan Hocking
+
+## calc. the epoch
+now <- Sys.time()
+the.epoch <- now - as.numeric(now)
+
 group2NA <- function(g, geom){
   poly.list <- split(g$data, g$data$group)
   is.group <- names(g$data) == "group"
@@ -47,12 +52,19 @@ pch2symbol <- c("0"="square",
 aes2marker <- c(alpha="opacity",
                 colour="color",
                 size="size",
+                sizeref="sizeref",
+                sizemode="sizemode",
                 shape="symbol")
 
-marker.defaults <- c(alpha=1,
-                     shape="o",
-                     size=1,
-                     colour="black")
+default.marker.sizeref = 1
+marker.size.mult <- 10
+
+marker.defaults <- list(alpha=1,
+                        shape="o",
+                        size=marker.size.mult,
+                        sizeref=default.marker.sizeref,
+                        sizemode="area",
+                        colour="black")
 line.defaults <-
   list(linetype="solid",
        colour="black",
@@ -96,12 +108,19 @@ lty2dash <- c(numeric.lty, named.lty, coded.lty)
 
 aesConverters <-
   list(linetype=function(lty){
-    lty2dash[as.character(lty)]
-  },colour=function(col){
-    toRGB(col)
-  },size=identity,alpha=identity,shape=function(pch){
-    pch2symbol[as.character(pch)]
-  }, direction=identity)
+         lty2dash[as.character(lty)]
+       },
+       colour=function(col){
+         toRGB(col)
+       },
+       size=identity,
+       sizeref=identity,
+       sizemode=identity,
+       alpha=identity,
+       shape=function(pch){
+         pch2symbol[as.character(pch)]
+       },
+       direction=identity)
 
 toBasic <-
   list(segment=function(g){
@@ -144,6 +163,7 @@ toBasic <-
     stop("TODO")
   })
 
+
 #' Convert basic geoms to traces.
 geom2trace <-
   list(path=function(data, params){
@@ -173,9 +193,10 @@ geom2trace <-
               mode="markers",
               marker=paramORdefault(params, aes2marker, marker.defaults))
     if("size" %in% names(data)){
-      L$marker$sizeref <- min(data$size)
-      L$marker$sizemode <- "area"
-      L$marker$size <- data$size
+      L$marker$sizeref <- default.marker.sizeref
+      ## Make sure sizes are passed as a list even when there is only one element.
+      marker.size <- data$size * marker.size.mult
+      L$marker$size <- if (length(marker.size) > 1) marker.size else list(marker.size)
     }
     L
   },
@@ -221,6 +242,8 @@ aes2line <- c(linetype="dash",
               direction="shape")
 
 markLegends <-
+  ## NOTE: Do we also want to split on size?
+##  list(point=c("colour", "fill", "shape", "size"),
   list(point=c("colour", "fill", "shape"),
        path=c("linetype", "size", "colour"),
        polygon=c("colour", "fill", "linetype", "size", "group"),
@@ -297,7 +320,6 @@ gg2list <- function(p){
     trace.list$plot <- built$plot$data
   }
 
-  ranges <- built$panel$ranges[[1]]
   for(i in seq_along(built$plot$layers)){
     ## This is the layer from the original ggplot object.
     L <- p$layers[[i]]
@@ -341,7 +363,18 @@ gg2list <- function(p){
         misc$breaks[[sc$aesthetics]] <- ranks
       }
     }
+
+    ## get gglayout now because we need some of its info in layer2traces
+    gglayout <- built$panel$layout
+    ## invert rows so that plotly and ggplot2 show panels in the same order
+    gglayout$plotly.row <- max(gglayout$ROW) - gglayout$ROW + 1
 
+    ## Add ROW and COL to df: needed to link axes to traces; keep df's
+    ## original ordering while merging.
+    df$order <- seq_len(nrow(df))
+    df <- merge(df, gglayout[,c("PANEL","plotly.row","COL")])
+    df <- df[order(df$order),]
+    df$order <- NULL
     ## This extracts essential info for this geom/layer.
     traces <- layer2traces(L, df, misc, trace.list$plot)
 
@@ -350,11 +383,12 @@ gg2list <- function(p){
     ##                                     built$panel$ranges[[1]])
     trace.list <- c(trace.list, traces)
   }
-  # Export axis specification as a combination of breaks and
-  # labels, on the relevant axis scale (i.e. so that it can
-  # be passed into d3 on the x axis scale instead of on the
-  # grid 0-1 scale). This allows transformations to be used
-  # out of the box, with no additional d3 coding.
+
+  ## Export axis specification as a combination of breaks and labels, on
+  ## the relevant axis scale (i.e. so that it can be passed into d3 on the
+  ## x axis scale instead of on the grid 0-1 scale). This allows
+  ## transformations to be used out of the box, with no additional d3
+  ## coding.
   theme.pars <- ggplot2:::plot_theme(p)
 
   ## Flip labels if coords are flipped - transform does not take care
@@ -430,6 +464,114 @@ gg2list <- function(p){
     !is.blank(s("axis.ticks.%s"))
     layout[[s("%saxis")]] <- ax.list
   }
+
+  ## copy [x/y]axis to [x/y]axisN and set domain, range, etc. for each
+  xaxis.title <- layout$xaxis$title
+  yaxis.title <- layout$yaxis$title
+  inner.margin <- 0.01 ## between facets
+  outer.margin <- 0.05 ## to put titles outside of the plots
+  orig.xaxis <- layout$xaxis
+  orig.yaxis <- layout$yaxis
+  if (nrow(gglayout) > 1)
+    {
+      row.size <- 1. / max(gglayout$ROW)
+      col.size <- 1. / max(gglayout$COL)
+      for (i in seq_len(nrow(gglayout)))
+        {
+          row <- gglayout[i, "plotly.row"] 
+          col <- gglayout[i, "COL"] 
+          x <- col * col.size
+          xmin <- x - col.size
+          xmax <- x - inner.margin
+          y <- row * row.size
+          ymin <- y - row.size
+          ymax <- y - inner.margin
+          yaxis.name <- if (row == 1) "yaxis" else paste0("yaxis", row)
+          xaxis.name <- if (col == 1) "xaxis" else paste0("xaxis", col)
+          layout[[xaxis.name]] <- orig.xaxis
+          layout[[xaxis.name]]$domain <- c(xmin, xmax)
+          layout[[xaxis.name]]$anchor <- "y"
+          layout[[xaxis.name]]$title <- NULL
+          if (orig.xaxis$type == "linear" && # range only makes sense for numeric data
+              (is.null(p$facet$scales) || p$facet$scales == "fixed" || p$facet$scales == "free_y"))
+            {
+              layout[[xaxis.name]]$range <- built$panel$ranges[[i]]$x.range
+              layout[[xaxis.name]]$autorange <- FALSE
+            }
+
+          layout[[yaxis.name]] <- orig.yaxis
+          layout[[yaxis.name]]$domain <- c(ymin, ymax)
+          layout[[yaxis.name]]$anchor <- "x"
+          layout[[yaxis.name]]$title <- NULL
+          if (orig.yaxis$type == "linear" && # range only makes sense for numeric data
+              (is.null(p$facet$scales) || p$facet$scales == "fixed" || p$facet$scales == "free_x"))
+            {
+              layout[[yaxis.name]]$range <- built$panel$ranges[[i]]$y.range
+              layout[[yaxis.name]]$autorange <- FALSE
+            }
+
+        }
+      ## add panel titles as annotations
+      annotations <- list()
+      nann <- 1
+      make.label <- function(text, x, y)
+        list(text=text, showarrow=FALSE, x=x, y=y, ax=0, ay=0, xref="paper", yref="paper")
+
+      if ("grid" %in% class(p$facet))
+        {
+          frows <- names(p$facet$rows)
+          nann <- 1
+
+          for (i in seq_len(max(gglayout$ROW)))
+            {
+              text <- paste(lapply(gglayout[gglayout$ROW == i, frows, drop=FALSE][1,],
+                                   as.character),
+                            collapse=", ")
+              annotations[[nann]] <- make.label(text, 1 + outer.margin, row.size * (max(gglayout$ROW)-i+0.5))
+              nann <- nann + 1
+            }
+
+          fcols <- names(p$facet$cols)
+          for (i in seq_len(max(gglayout$COL)))
+            {
+              text <- paste(lapply(gglayout[gglayout$COL == i, fcols, drop=FALSE][1,],
+                                   as.character),
+                            collapse=", ")
+              annotations[[nann]] <- make.label(text, col.size * (i-0.5) - inner.margin/2, 1 + outer.margin)
+              nann <- nann + 1
+            }
+
+          ## add empty traces everywhere so that the background shows even if there
+          ## is no data for a facet
+          for (r in seq_len(max(gglayout$ROW)))
+            for (c in seq_len(max(gglayout$COL)))
+              trace.list <- c(trace.list, list(list(xaxis=paste0("x", c), yaxis=paste0("y", r), showlegend=FALSE)))
+        }
+      else if ("wrap" %in% class(p$facet))
+        {
+          facets <- names(p$facet$facets)
+          for (i in seq_len(max(as.numeric(gglayout$PANEL))))
+            {
+              ix <- gglayout$PANEL == i
+              row <- gglayout$ROW[ix]
+              col <- gglayout$COL[ix]
+              text <- paste(lapply(gglayout[ix, facets, drop=FALSE][1,],
+                                   as.character),
+                            collapse=", ")
+              annotations[[nann]] <- make.label(text, col.size * (col-0.5) - inner.margin/2,
+                                                row.size * (max(gglayout$ROW) - row + 1))
+              nann <- nann + 1
+            }
+          }
+
+      ## axes titles
+      annotations[[nann]] <- make.label(xaxis.title, 0.5, -outer.margin)
+      nann <- nann + 1
+      annotations[[nann]] <- make.label(yaxis.title, -outer.margin, 0.5)
+      nann <- nann + 1
+
+      layout$annotations <- annotations
+    }
 
   ## Remove legend if theme has no legend position
   if(theme.pars$legend.position=="none") layout$showlegend <- FALSE
@@ -465,18 +607,20 @@ layer2traces <- function(l, d, misc, plot=NULL){
             plot=plot)
   ## needed for when group, etc. is an expression.
   g$aes <- sapply(l$mapping, function(k) as.character(as.expression(k)))
-
+  
   ## For non-numeric data on the axes, we should take the values from
   ## the original data.
-  for(axis.name in c("x", "y")){
-    if(!misc$is.continuous[[axis.name]]){
+  for (axis.name in c("x", "y")){
+    if (!misc$is.continuous[[axis.name]]){
       aes.names <- paste0(axis.name, c("", "end", "min", "max"))
       aes.used <- aes.names[aes.names %in% names(g$aes)]
       for(a in aes.used){
         col.name <- g$aes[aes.used]
         data.vec <- l$data[[col.name]]
-        if(inherits(data.vec, "POSIXt")){
-          data.vec <- strftime(data.vec, "%Y-%m-%d %H:%M:%S")
+        if (inherits(data.vec, "POSIXt")) {
+          ## Re-create dates from nb seconds
+          data.vec <- strftime(as.POSIXlt(g$data[[a]], origin=the.epoch),
+                               "%Y-%m-%d %H:%M:%S")
         } else if (inherits(data.vec, "factor")) {
           ## Re-order data so that Plotly gets it right from ggplot2.
           g$data <- g$data[order(g$data[[a]]),]
@@ -486,6 +630,7 @@ layer2traces <- function(l, d, misc, plot=NULL){
       }
     }
   }
+
   ## use un-named parameters so that they will not be exported
   ## to JSON as a named object, since that causes problems with
   ## e.g. colour.
@@ -525,7 +670,6 @@ layer2traces <- function(l, d, misc, plot=NULL){
   }else{
     convert(g)
   }
-
   ## Then split on visual characteristics that will get different
   ## legend entries.
   data.list <- if(basic$geom %in% names(markLegends)){
@@ -540,29 +684,30 @@ layer2traces <- function(l, d, misc, plot=NULL){
     ##   mark.names <- mark.names[!mark.names %in% to.erase]
     ## }
     name.names <- sprintf("%s.name", mark.names)
-    is.split <- names(basic$data) %in% name.names
+    ## split on 'PANEL' to support facets
+    is.split <- names(basic$data) %in% c(name.names, "PANEL")
     if(any(is.split)){
       data.i <- which(is.split)
       matched.names <- names(basic$data)[data.i]
-      name.i <- which(name.names %in% matched.names)
+      name.i <- name.names %in% matched.names
       invariable.names <- cbind(name.names, mark.names)[name.i,]
       other.names <- !names(basic$data) %in% invariable.names
       vec.list <- basic$data[is.split]
       df.list <- split(basic$data, vec.list, drop=TRUE)
       lapply(df.list, function(df){
         params <- basic$params
-        params[invariable.names] <- df[1, invariable.names]
+        params[invariable.names] <- if (ncol(x <- df[1, invariable.names]) > 0) x else NULL
         list(data=df[other.names],
              params=params)
       })
     }
   }
+
   ## case of no legend, if either of the two ifs above failed.
   if(is.null(data.list)){
     data.list <- structure(list(list(data=basic$data, params=basic$params)),
                            names=basic$params$name)
   }
-
   getTrace <- geom2trace[[basic$geom]]
   if(is.null(getTrace)){
     warning("Conversion not implemented for geom_",
@@ -572,6 +717,7 @@ layer2traces <- function(l, d, misc, plot=NULL){
     return(list())
   }
   traces <- NULL
+  names.in.legend <- NULL
   for(data.i in seq_along(data.list)){
     data.params <- data.list[[data.i]]
     tr <- do.call(getTrace, data.params)
@@ -594,8 +740,21 @@ layer2traces <- function(l, d, misc, plot=NULL){
       name.list <- data.params$params[name.names]
       tr$name <- paste(unlist(name.list), collapse=".")
     }
+
+    dpd <- data.params$data
+    if ("PANEL" %in% names(dpd) && nrow(dpd) > 0)
+      {
+        tr$xaxis <- paste0("x", dpd[1, "COL"])
+        tr$yaxis <- paste0("y", dpd[1, "plotly.row"])
+      }
+
+    if (is.null(tr$name) || tr$name %in% names.in.legend)
+        tr$showlegend <- FALSE
+    names.in.legend <- c(names.in.legend, tr$name)
+
     traces <- c(traces, list(tr))
   }
+
   sort.val <- sapply(traces, function(tr){
     rank.val <- unlist(tr$sort)
     if(is.null(rank.val)){
@@ -606,6 +765,7 @@ layer2traces <- function(l, d, misc, plot=NULL){
       0
     }
   })
+
   ord <- order(sort.val)
   no.sort <- traces[ord]
   for(tr.i in seq_along(no.sort)){
@@ -630,7 +790,6 @@ paramORdefault <- function(params, aesVec, defaults){
       ggplot.value <- defaults[[ggplot.name]]
     }
     if(is.null(ggplot.value)){
-      print(defaults)
       stop("no ggplot default for ", ggplot.name)
     }
     convert <- aesConverters[[ggplot.name]]