merge with toby-fixes

Author: cpsievert

NEWS

@@ -1,3 +1,20 @@
+TO DISCUSS
+
+for plotlys with panels, does list(xaxis="x1") mean "xaxis" and
+list(xaxis="x2") mean "xaxis2" ?
+
+unevenly spaced ticks? 
+scale_y_continuous(breaks=c(4, 4.25, 4.5, 5, 6,8))
+
+R-GSOC project?
+
+Visual testing table instead of GitHub diffs?
+http://sugiyama-www.cs.titech.ac.jp/~toby/flags/
+https://sjp.co.nz/projects/grimport2/
+https://dl.dropboxusercontent.com/u/54315147/import/state-table.html
+
+Use RSelenium for headless browser testing?
+
 0.5.20 -- 9 February 2015.
 
 Add alpha transparency to fill conversion.

R/corresp_one_one.R

@@ -81,8 +81,12 @@ coded.lty <- c("22"="dash",
                "224282F2"="dash",
                "F1"="dash")
 
+# Convert R lty line type codes to plotly "dash" codes.
+lty2dash <- c(numeric.lty, named.lty, coded.lty)
+
 # Convert ggplot2 aes to line parameters.
 aes2line <- c(linetype="dash",
               colour="color",
               size="width",
               direction="shape")
+

R/ggplotly.R

@@ -54,6 +54,8 @@ markLegends <-
        path=c("linetype", "size", "colour", "shape"),
        polygon=c("colour", "fill", "linetype", "size", "group"),
        bar=c("colour", "fill"),
+       errorbar=c("colour", "linetype"),
+       errorbarh=c("colour", "linetype"),
        area=c("colour", "fill"),
        step=c("linetype", "size", "colour"),
        boxplot=c("x"),
@@ -103,7 +105,6 @@ gg2list <- function(p){
 
   ## Extract data from built ggplots
   built <- ggplot_build2(p)
-  
   # Get global x-range now because we need some of its info in layer2traces
   ggranges <- built$panel$ranges
   # Extract x.range
@@ -164,7 +165,9 @@ gg2list <- function(p){
         names(ranks) <- br
         misc$breaks[[sc$aesthetics]] <- ranks
       }
+      misc$trans[sc$aesthetics] <- sc$trans$name
     }
+    reverse.aes <- names(misc$trans)[misc$trans=="reverse"]
 
     ## get gglayout now because we need some of its info in layer2traces
     gglayout <- built$panel$layout
@@ -180,9 +183,17 @@ gg2list <- function(p){
     df <- merge(df, gglayout[, c("PANEL", "plotly.row", "COL")])
     df <- df[order(df$order),]
     df$order <- NULL
-    
-    misc$prestats.data <- merge(built$prestats.data[[i]],
-                                gglayout[, c("PANEL", "plotly.row", "COL")])
+
+    prestats <- built$prestats.data[[i]]
+    ## scale_reverse multiples x/y data by -1, so here we undo that so
+    ## that the actual data can be uploaded to plotly.
+    replace.aes <- intersect(names(prestats), reverse.aes)
+    for(a in replace.aes){
+      prestats[[a]] <- -1 * prestats[[a]]
+    }
+    misc$prestats.data <-
+      merge(prestats,
+            gglayout[, c("PANEL", "plotly.row", "COL")])
 
     # Add global x-range info
     misc$prestats.data$globxmin <- ggxmin
@@ -201,7 +212,8 @@ gg2list <- function(p){
     traces <- layer2traces(L, df, misc)
 
     # Associate error bars with previous traces
-    if (grepl("errorbar", L$geom$objname)) {
+    ##if (grepl("errorbar", L$geom$objname)) { #TDH 28 Jan 2015.
+    if(FALSE){
       for (j in 1:length(trace.list)) {
         temp <- list()
         ind <- traces[[1]]$x %in% trace.list[[j]]$x
@@ -274,6 +286,8 @@ gg2list <- function(p){
     cls <- attr(e(el.name),"class")
     "element_blank" %in% cls || null.is.blank && is.null(cls)
   }
+  trace.order.list <- list()
+  trace.name.map <- c()
   for(xy in c("x","y")){
     ax.list <- list()
     s <- function(tmp)sprintf(tmp, xy)
@@ -324,6 +338,29 @@ gg2list <- function(p){
     scale.i <- which(p$scales$find(xy))
     ax.list$title <- if(length(scale.i)){
       sc <- p$scales$scales[[scale.i]]
+      trace.order.list[[xy]] <- sc$limits
+      trace.name.map[sc$breaks] <- sc$labels
+      if(is.null(sc$breaks)){
+        ax.list$showticklabels <- FALSE
+        ax.list$showgrid <- FALSE
+        ax.list$ticks <- ""
+      }
+      if(is.numeric(sc$breaks)){
+        dticks <- diff(sc$breaks)
+        dt <- dticks[1]
+        if(all(dticks == dt)){
+          ax.list$dtick <- dt
+          ax.list$autotick <- FALSE
+        }
+      }
+      ax.list$range <- if(!is.null(sc$limits)){
+        sc$limits
+      }else{
+        ggranges[[1]][[s("%s.range")]] #TODO: facets!
+      }
+      if(is.character(sc$trans$name) && sc$trans$name == "reverse"){
+        ax.list$range <- sort(-ax.list$range, decreasing = TRUE)
+      }
       if(!is.null(sc$name)){
         sc$name
       }else{
@@ -332,6 +369,7 @@ gg2list <- function(p){
     }else{
       p$labels[[xy]]
     }
+
     title.text <- e(s("axis.title.%s"))
     ax.list$titlefont <- theme2font(title.text)
     ax.list$type <- if(misc$is.continuous[[xy]]){
@@ -643,63 +681,103 @@ gg2list <- function(p){
       layout$legend$bgcolor <- toRGB(s(rect_fill))
   }
 
-  trace.list$kwargs <- list(layout=layout)
-  
-  if (length(trace.list) < 2) {
+  if(length(trace.list) == 0) {
     stop("No exportable traces")
   }
-  
-  if (length(trace.list) > 2) {
-    # Maybe some traces should be merged.
-    nr <- length(trace.list) - 1
-    comp <- data.frame(matrix(ncol=2, nrow=nr))
-    colnames(comp) <- c("name", "mode")
-    
-    for (j in 1:nr) {
-      # Use lapply to be elegant?
-      for (d in colnames(comp)) {
-        try(comp[[d]][j] <- trace.list[[j]][[d]], silent=TRUE)
-        # "names" might be NULL in trace.list
+
+  mode.mat <- matrix(NA, 3, 3)
+  rownames(mode.mat) <- colnames(mode.mat) <- c("markers", "lines", "none")
+  mode.mat["markers", "lines"] <-
+    mode.mat["lines", "markers"] <- "lines+markers"
+  mode.mat["markers", "none"] <- mode.mat["none", "markers"] <- "markers"
+  mode.mat["lines", "none"] <- mode.mat["none", "lines"] <- "lines"
+  merged.traces <- list()
+  not.merged <- trace.list
+  while(length(not.merged)){
+    tr <- not.merged[[1]]
+    not.merged <- not.merged[-1]
+    ## Are there any traces that have not yet been merged, and can be
+    ## merged with tr?
+    can.merge <- rep(FALSE, l=length(not.merged))
+    for(other.i in seq_along(not.merged)){
+      other <- not.merged[[other.i]]
+      criteria <- c()
+      for(must.be.equal in c("x", "y", "xaxis", "yaxis")){
+        other.attr <- other[[must.be.equal]]
+        tr.attr <- tr[[must.be.equal]]
+        criteria[[must.be.equal]] <- isTRUE(all.equal(other.attr, tr.attr))
+      }
+      if(all(criteria)){
+        can.merge[[other.i]] <- TRUE
       }
     }
-    # Compare the "name"s of the traces (so far naively inherited from layers)
-    layernames <- unique(comp$name)
-    if (length(layernames) < nr) {
-      # Some traces (layers at this stage) have the same "name"s.
-      for (j in 1:length(layernames)) {
-        lind <- which(layernames[j] == comp$name)
-        lmod <- c("lines", "markers") %in% comp$mode[lind]
-        # Is there one with "mode": "lines" and another with "mode": "markers"?
-        if (all(lmod)) {
-          # Data comparison
-          xcomp <- (trace.list[[lind[1]]]$x == trace.list[[lind[2]]]$x)
-          ycomp <- (trace.list[[lind[1]]]$y == trace.list[[lind[2]]]$y)
-          if (all(xcomp) && all(ycomp)) {
-            # Union of the two traces
-            keys <- unique(c(names(trace.list[[lind[1]]]),
-                             names(trace.list[[lind[2]]])))
-            temp <- setNames(mapply(c, trace.list[[lind[1]]][keys],
-                                    trace.list[[lind[2]]][keys]), keys)
-            # Info is duplicated in fields which are in common
-            temp <- lapply(temp, unique)
-            # But unique() is detrimental to line or marker sublist
-            temp$line <- trace.list[[lind[1]]]$line
-            temp$marker <- trace.list[[lind[2]]]$marker
-            # Overwrite x and y to be safe
-            temp$x <- trace.list[[lind[1]]]$x
-            temp$y <- trace.list[[lind[1]]]$y
-            # Specify new one mode
-            temp$mode <- "lines+markers"
-            # Keep one trace and remove the other one
-            trace.list[[lind[1]]] <- temp
-            trace.list <- trace.list[-lind[2]]
-            # Update comparison table
-            comp <- comp[-lind[2], ]
-          }
+    to.merge <- not.merged[can.merge]
+    not.merged <- not.merged[!can.merge]
+    for(other in to.merge){
+      new.mode <- tryCatch({
+        mode.mat[tr$mode, other$mode]
+      }, error=function(e){
+        NA
+      })
+      if(is.character(new.mode) && !is.na(new.mode)){
+        tr$mode <- new.mode
+      }
+      attrs <- c("error_x", "error_y", "marker", "line")
+      for(attr in attrs){
+        if(!is.null(other[[attr]]) && is.null(tr[[attr]])){
+          tr[[attr]] <- other[[attr]]
         }
       }
     }
+    merged.traces[[length(merged.traces)+1]] <- tr
   }
+
+  ## Put the traces in correct order, according to any manually
+  ## specified scales.
+  trace.order <- unlist(trace.order.list)
+  ordered.traces <- if(length(trace.order)){
+    trace.order.score <- seq_along(trace.order)
+    names(trace.order.score) <- trace.order
+    trace.name <- sapply(merged.traces, "[[", "name")
+    trace.score <- trace.order.score[trace.name]
+    merged.traces[order(trace.score)]
+  }else{
+    merged.traces
+  }
+
+  ## Translate scale(labels) to trace name.
+  named.traces <- ordered.traces
+  for(trace.i in seq_along(named.traces)){
+    tr.name <- named.traces[[trace.i]][["name"]]
+    new.name <- trace.name.map[[tr.name]]
+    if(!is.null(new.name)){
+      named.traces[[trace.i]][["name"]] <- new.name
+    }
+  }
+  
+  ## If coord_flip is defined, then flip x/y in each trace, and in
+  ## each axis.
+  flipped.traces <- named.traces
+  flipped.layout <- layout
+  if("flip" %in% attr(built$plot$coordinates, "class")){
+    if(!inherits(p$facet, "null")){
+      stop("coord_flip + facet conversion not supported")
+    }
+    for(trace.i in seq_along(flipped.traces)){
+      tr <- flipped.traces[[trace.i]]
+      x <- tr[["x"]]
+      y <- tr[["y"]]
+      tr[["y"]] <- x
+      tr[["x"]] <- y
+      flipped.traces[[trace.i]] <- tr
+    }
+    x <- layout[["xaxis"]]
+    y <- layout[["yaxis"]]
+    flipped.layout[["xaxis"]] <- y
+    flipped.layout[["yaxis"]] <- x
+  }
+
+  flipped.traces$kwargs <- list(layout=flipped.layout)
 
-  trace.list
+  flipped.traces
 }

R/print.R

@@ -0,0 +1,4 @@
+print.trace <- function(x, ...){
+  str(x)
+  invisible(x)
+}

R/trace_generation.R

@@ -5,9 +5,14 @@
 #' @return list representing a layer, with corresponding aesthetics, ranges, and groups.
 #' @export
 layer2traces <- function(l, d, misc) {
+  not.na <- function(df){
+    na.mat <- is.na(df)
+    to.exclude <- apply(na.mat, 1, any)
+    df[!to.exclude, ]
+  }
   g <- list(geom=l$geom$objname,
-            data=d,
-            prestats.data=misc$prestats.data)
+            data=not.na(d),
+            prestats.data=not.na(misc$prestats.data))
   ## needed for when group, etc. is an expression.
   g$aes <- sapply(l$mapping, function(k) as.character(as.expression(k)))
   # Partial conversion for geom_violin (Plotly does not offer KDE yet)
@@ -41,8 +46,8 @@ layer2traces <- function(l, d, misc) {
 
   ## 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) {
@@ -61,7 +66,7 @@ layer2traces <- function(l, d, misc) {
         }
 
         # For some plot types, we overwrite `data` with `prestats.data`.
-        pdata.vec <- misc$prestats.data[[a]]
+        pdata.vec <- g$prestats.data[[a]]
         if (inherits(data.vec, "POSIXt")) {
           ## Re-create dates from nb seconds
           data.vec <- try(strftime(as.POSIXlt(g$data[[a]], origin=the.epoch),
@@ -198,6 +203,7 @@ layer2traces <- function(l, d, misc) {
     data.params <- data.list[[data.i]]
     data.params$params$stat.type <- l$stat$objname
     tr <- do.call(getTrace, data.params)
+    class(tr) <- "trace"
     for (v.name in c("x", "y")) {
       vals <- tr[[v.name]]
       if (length(vals) > 0 && is.na(vals[length(vals)])) {
@@ -378,6 +384,35 @@ group2NA <- function(g, geom) {
   g
 }
 
+### Make a trace for geom_errorbar -> error_y or geom_errorbarh ->
+### error_x.
+make.errorbar <- function(data, params, xy){
+  tr <-
+    list(x=data$x,
+         y=data$y,
+         type="scatter",
+         mode="none")
+  err.name <- paste0("error_", xy)
+  min.name <- paste0(xy, "min")
+  max.name <- paste0(xy, "max")
+  e <-
+    list(array=data[[max.name]]-data[[xy]],
+         type="data",
+         width=params$width,
+         symmetric=TRUE,
+         color=if(!is.null(params$colour)){
+           toRGB(params$colour)
+         }else{
+           toRGB(data$colour)
+         })
+  arrayminus <- data[[xy]]-data[[min.name]]
+  if(!isTRUE(all.equal(e$array, arrayminus))){
+    e$arrayminus <- arrayminus
+    e$symmetric <- FALSE
+  }
+  tr[[err.name]] <- e    
+  tr
+}
 
 # Convert basic geoms to traces.
 geom2trace <- list(
@@ -536,18 +571,10 @@ geom2trace <- list(
     L
   },
   errorbar=function(data, params) {
-    list(x=data$x,
-         y=data$y,
-         error_y=list(arrayminus=data$y-data$ymin,
-                      array=data$ymax-data$y,
-                      color=toRGB(data$colour)))
+    make.errorbar(data, params, "y")
   },
   errorbarh=function(data, params) {
-    list(x=data$x,
-         y=data$y,
-         error_x=list(arrayminus=data$x-data$xmin,
-                      array=data$xmax-data$x,
-                      color=toRGB(data$colour)))
+    make.errorbar(data, params, "x")
   },
   area=function(data, params) {
     list(x=c(data$x[1], data$x, tail(data$x, n=1)),