Merge pull request #146 from ropensci/marianne-merge-layersintotraces

Little hack to make layers geom_line + geom_point 1 trace in Plotly

Author: mkcor

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: plotly
 Type: Package
 Title: Interactive, publication-quality graphs online.
-Version: 0.5.13
+Version: 0.5.14
 Authors@R: c(person("Chris", "Parmer", role = c("aut", "cre"),
     email = "[email protected]"),
     person("Scott", "Chamberlain", role = "aut",

NEWS

@@ -1,3 +1,7 @@
+0.5.14 -- 1 December 2014.
+
+Make layers geom_line + geom_point only one trace in Plotly.
+
 0.5.13 -- 27 November 2014.
 
 Rename translation file and server endpoint parameter to be hip.
@@ -12,7 +16,7 @@ Show legend title.
 
 0.5.10 -- 7 November 2014.
 
-Improve showlegend and fix legend’s ’x’ position.
+Improve showlegend and fix legend’s `x` position.
 
 0.5.9 -- 3 November 2014.
 

R/ggplotly.R

@@ -612,9 +612,62 @@ gg2list <- function(p){
   }
 
   trace.list$kwargs <- list(layout=layout)
-  if(length(trace.list) < 2){
+  
+  if (length(trace.list) < 2) {
     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
+      }
+    }
+    # 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], ]
+          }
+        }
+      }
+    }
+  }
+  
   trace.list
 }

tests/testthat/test-ggplot-path.R

@@ -73,14 +73,14 @@ test_that("lines work with aesthetic shape", {
     geom_line() +
     geom_point()
   info <- gg2list(gg)
-  expect_equal(length(info), 5)  # 2 lines and 2 sets of points for each group
-  expect_identical(info[[3]]$name, "Female")
-  expect_identical(info[[3]]$marker$symbol, "circle")
-  expect_identical(info[[4]]$name, "Male")
-  expect_identical(info[[4]]$marker$symbol, "triangle-up")
+  expect_equal(length(info), 3)  # 2 traces + layout
+  expect_identical(info[[1]]$name, "Female")
+  expect_identical(info[[1]]$marker$symbol, "circle")
+  expect_identical(info[[2]]$name, "Male")
+  expect_identical(info[[2]]$marker$symbol, "triangle-up")
   # Layout
-  expect_identical(info[[5]]$layout$xaxis$title, "time")
-  expect_identical(info[[5]]$layout$xaxis$type, "category")
+  expect_identical(info[[3]]$layout$xaxis$title, "time")
+  expect_identical(info[[3]]$layout$xaxis$type, "category")
 
   save_outputs(gg, "path-line-symbols")
 })