Fixes for error bars and ticks

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

@@ -26,9 +26,6 @@ ribbon.line.defaults$colour <- NA
 polygon.line.defaults <- line.defaults
 polygon.line.defaults$colour <- NA
 
-# Convert R lty line type codes to plotly "dash" codes.
-lty2dash <- c(numeric.lty, named.lty, coded.lty)
-
 aesConverters <- list(linetype=function(lty) {
                         lty2dash[as.character(lty)]
                       },
@@ -52,6 +49,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"),
        step=c("linetype", "size", "colour"),
        boxplot=c("x"),
        text=c("colour"))
@@ -195,7 +194,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
@@ -612,63 +612,58 @@ 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
   }
+
+  merged.traces$kwargs <- list(layout=layout)
 
-  trace.list
+  merged.traces
 }

R/print.R

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

R/trace_generation.R

@@ -198,6 +198,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 +379,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 +566,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)),

tests/testthat/test-ggplot-errorbar-horizontal.R

@@ -0,0 +1,27 @@
+context("geom_errorbarh")
+
+test_that("geom_errorbarh gives horizontal errorbars", {
+
+  df <- data.frame(
+    trt = factor(c(1, 1, 2, 2)),
+    resp = c(1, 5, 3, 4),
+    group = factor(c(1, 2, 1, 2)),
+    se = c(0.1, 0.3, 0.3, 0.4)
+  )
+  g <- ggplot(df, aes(resp, trt, colour=group)) + geom_point()
+  # Define the limits of the horizontal errorbars
+  g <- g + geom_errorbarh(aes(xmax = resp + se, xmin = resp - se))
+
+  L <- gg2list(g)
+
+  # Expect 2 traces
+  expect_equal(length(L), 3)
+  # Expect scatter plot and its error bars to have the same color
+  expect_identical(L[[1]]$marker$color, L[[1]]$error_x$color)
+  expect_identical(L[[2]]$marker$color, L[[2]]$error_x$color)
+  # Expect given errorbar values
+  expect_equal(L[[1]]$error_x$array, c(0.1, 0.3))
+  expect_equal(L[[1]]$error_x$symmetric, TRUE)
+
+  save_outputs(g, "errorbar-horizontal")
+})

tests/testthat/test-ggplot-errorbar.R

@@ -19,28 +19,3 @@ test_that("geom_errorbar gives errorbars", {
   save_outputs(g, "errorbar")
 })
 
-test_that("geom_errorbarh gives horizontal errorbars", {
-
-  df <- data.frame(
-    trt = factor(c(1, 1, 2, 2)),
-    resp = c(1, 5, 3, 4),
-    group = factor(c(1, 2, 1, 2)),
-    se = c(0.1, 0.3, 0.3, 0.4)
-  )
-  g <- ggplot(df, aes(resp, trt, colour=group)) + geom_point()
-  # Define the limits of the horizontal errorbars
-  g <- g + geom_errorbarh(aes(xmax = resp + se, xmin = resp - se))
-
-  L <- gg2list(g)
-
-  # Expect 2 traces
-  expect_equal(length(L), 3)
-  # Expect scatter plot and its error bars to have the same color
-  expect_identical(L[[1]]$marker$color, L[[1]]$error_x$color)
-  expect_identical(L[[2]]$marker$color, L[[2]]$error_x$color)
-  # Expect given errorbar values
-  expect_equal(L[[1]]$error_x$arrayminus, c(0.1, 0.3))
-  expect_equal(L[[1]]$error_x$array, L[[1]]$error_x$arrayminus)
-
-  save_outputs(g, "errorbar-horizontal")
-})

tests/testthat/test-ggplot-heatmap.R

@@ -4,10 +4,12 @@ wdays <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
 dtimes <- c("Morning", "Afternoon", "Evening")
 workweek <- matrix(c(1, 20, 30, 20, 1, 60, 30, 60, 1, 50, 80, -10, 1, 30, 20),
              nrow=5, ncol=3, byrow=TRUE,
-             dimnames=list(wdays, dtimes))
+             dimnames=list(day=wdays, time=dtimes))
 ww <- reshape2::melt(workweek)
+ww$day <- factor(ww$day, wdays)
+ww$time <- factor(ww$time, dtimes)
 # Plot a heatmap using geom_tile
-hm <- ggplot(ww) + geom_tile(aes(x=Var1, y=Var2, fill=value))
+hm <- ggplot(ww) + geom_tile(aes(x=day, y=time, fill=value))
 
 test_that("geom_tile is translated to type=heatmap", {
     L <- gg2list(hm)

tests/testthat/test-ggplot-theme.R

@@ -1,6 +1,8 @@
 context("ggplot themes")
 
-iris.base <- ggplot(iris) + geom_point(aes(Petal.Width, Sepal.Width))
+iris.base <- ggplot(iris) +
+  geom_point(aes(Petal.Width, Sepal.Width))+
+  theme_grey()
 
 test_that("background translated correctly",{
   ggiris <- iris.base + theme(panel.background=element_rect(fill="blue")) +
@@ -54,10 +56,9 @@ test_that("dotted/dashed grid translated as line with alpha=0.1",{
   for (xy in c("x", "y")) {
     ax.list <- info$kwargs$layout[[paste0(xy, "axis")]]
     expect_identical(ax.list$gridcolor, toRGB("white", 0.1))
-    expect_identical(ax.list$gridcolor, "rgba(255,255,255,0.1)")
   }
 
-    save_outputs(ggiris, "theme-dashed-grid-lines")
+  save_outputs(ggiris, "theme-dashed-grid-lines")
 })
 
 countrypop <- data.frame(country=c("Paraguay", "Peru", "Philippines"),