explicit bar positioning and proper inverse transforming of dates via dynamicTicks

fixes #560, #874, #901, #831

Author: cpsievert

NEWS.md

@@ -27,11 +27,13 @@
 
 ## BUG FIXES
 
+
+* Placement of bars (in all cases, even when representing a negative count) should now be correct (applies to `geom_bar()`, `geom_histogram()`, `geom_col()`). Fixes #560, #874, #901, #831.
+* Fix for hoverinfo displaying the heights of bars in the translation `geom_bar()` via `ggplotly()`. Fixes #557 and #662.
 * `embed_notebook()` now works in *nteract* notebooks (see #768). 
 * Axis categories are no longer reordered for matrices (see #863).
-* Fix for hoverinfo displaying the heights of bars in the translation `geom_bar()` via `ggplotly()`. Fixes #557 and #662.
-* Fix for hoverinfo displaying values after scale transformations. Fixes #804.
-* Font faces for axis titles are now translated in `ggplotly()`. Fixes #861.
+* Fix for hoverinfo displaying values after scale transformations (in `ggplotly()`). Fixes #804.
+* Font faces for axis titles are now translated (in `ggplotly()`). Fixes #861.
 
 # 4.5.6
 

R/ggplotly.R

@@ -640,32 +640,37 @@ gg2list <- function(p, width = NULL, height = NULL,
         titlefont = text2font(axisTitle)
       )
 
-      # ensure dates/datetimes are put on the same millisecond scale
-      # (necessary regardless of whether axis is dynamic)
-      # TODO: inverse transform to the original dates?!
-      # https://github.com/plotly/plotly.js/issues/420
-      if (isDate) {
-        # convert days (date) / seconds (datetime) to milliseconds
-        # (86400000 = 24 * 60 * 60 * 1000)
-        constant <- if ("date" %in% sc$scale_name) 86400000 else 1000
-        axisObj$range <- axisObj$range * constant
-        if (i == 1) {
-          traces <- lapply(traces, function(z) { z[[xy]] <- z[[xy]] * constant; z })
-        }
-      }
-      
       # tickvals are currently on 0-1 scale, but we want them on data scale
       axisObj$tickvals <- scales::rescale(
         axisObj$tickvals, to = axisObj$range, from = c(0, 1)
       )
 
+      # inverse transform date data based on tickvals/ticktext
+      if (isDateType) {
+        as_date <- function(x) as.POSIXct(x, origin="1970-01-01", tz=sc$timezone)
+        axisObj$range <- as_date(axisObj$range)
+        traces <- lapply(traces, function(tr) {
+          tr[[xy]] <- as_date(tr[[xy]])
+          # TODO: are there other similar cases we need to handle?
+          if (identical("bar", tr$type)) {
+            tr[["width"]] <- as_date(tr[["width"]])
+            tr[["base"]] <- as_date(tr[["base"]])
+          }
+          tr
+        })
+      }
+      
       # inverse transform categorical data based on tickvals/ticktext
       if (isDiscreteType) {
-        tickMap <- with(axisObj, setNames(ticktext, tickvals))
         traces <- lapply(traces, function(tr) { 
-          tr[[xy]] <- tickMap[[as.character(tr[[xy]])]]
+          # map x/y trace data back to the 'closest' ticktext label
+          # http://r.789695.n4.nabble.com/check-for-nearest-value-in-a-vector-td4369339.html
+          tr[[xy]]<- vapply(tr[[xy]], function(val) {
+            with(axisObj, ticktext[[which.min(abs(tickvals - val))]])
+          }, character(1))
           tr
         })
+        if ("dodge" %in% sapply(layers, ggtype, "position")) gglayout$barmode <- "dodge"
       }
 
       # attach axis object to the layout
@@ -857,44 +862,13 @@ gg2list <- function(p, width = NULL, height = NULL,
     }
   }
 
-  # geom_bar() hacks
-  geoms <- sapply(layers, ggtype, "geom")
-  if (any(idx <- geoms %in% c("bar", "col"))) {
-    # traces were reversed in layers2traces()
-    gglayout$legend$traceorder <- "reversed"
-    # since `layout.barmode` is plot-specific, we can't support multiple bar
-    # geoms with different positions
-    positions <- sapply(layers, ggtype, "position")
-    position <- unique(positions[idx])
-    if (length(position) > 1) {
-      warning("plotly doesn't support multiple positions\n",
-              "across geom_bar() layers", call. = FALSE)
-      position <- position[1]
-    }
-    # hacks for position_identity()
-    if ("identity" %in% position) {
-      gglayout$barmode <- "overlay"
-    } else {
-      # yes, this should work even for position_dodge()
-      gglayout$barmode <- "stack"
-    }
-    # note: ggplot2 doesn't flip x/y scales when the coord is flipped
-    # (i.e., at this point, y should be the count/density)
-    is_hist <- inherits(plot$scales$get_scales("x"), "ScaleContinuous")
-    # TODO: get rid of this and use explicit width for bars
-    # https://github.com/plotly/plotly.js/issues/80
-    if (position == "dodge" || is_hist) {
-      gglayout$bargap <- 0
-    }
-  }
-  
   # flip x/y in traces for flipped coordinates
   # (we've already done appropriate flipping for axis objects)
   if (inherits(plot$coordinates, "CoordFlip")) {
     for (i in seq_along(traces)) {
       tr <- traces[[i]]
-      traces[[i]][c("x", "y")] <- tr[c("y", "x")]
-      if (tr$type %in% c("bar", "box")) traces[[i]]$orientation <- "h"
+      # TODO: move this to the layer2trace definition...
+      if (tr$type %in% "box") traces[[i]]$orientation <- "h"
       if (tr$type == "box") traces[[i]]$hoverinfo <- "x"
       names(traces[[i]])[grepl("^error_y$", names(tr))] <- "error_x"
       names(traces[[i]])[grepl("^error_x$", names(tr))] <- "error_y"
@@ -950,6 +924,7 @@ gg2list <- function(p, width = NULL, height = NULL,
 
   gglayout$width <- width
   gglayout$height <- height
+  gglayout$barmode <- gglayout$barmode %||% "relative"
 
   l <- list(
     data = setNames(traces, NULL),

R/layers2traces.R

@@ -641,12 +641,30 @@ geom2trace.GeomPoint <- function(data, params, p) {
 
 #' @export
 geom2trace.GeomBar <- function(data, params, p) {
-  data[["y"]] <- data[["ymax"]] - data[["ymin"]]
-  # TODO: use xmin/xmax once plotly.js allows explicit bar widths
-  # https://github.com/plotly/plotly.js/issues/80
+  # TODO: does position play a role here?
+  #pos <- params$position %||% "stack"
+  flip <- inherits(p$coordinates, "CoordFlip")
+  
+  if (!flip) {
+    width <- with(data, xmax - xmin)
+    # TODO: does this cause rounding issues when inverse transforming for dynamicTicks?
+    x <- with(data, (xmax + xmin) / 2)
+    base <- data[["ymin"]]
+    y <- with(data, ymax - ymin)
+  } else {
+    width <- with(data, ymax - ymin)
+    # TODO: does this cause rounding issues when inverse transforming for dynamicTicks?
+    y <- with(data, (ymax + ymin) / 2)
+    base <- data[["xmin"]]
+    x <- with(data, xmax - xmin)
+  }
+  
   compact(list(
-    x = data[["x"]],
-    y = data[["y"]],
+    orientation = if (flip) "h" else "v",
+    width = width,
+    base = base,
+    x = x,
+    y = y,
     text = uniq(data[["hovertext"]]),
     key = data[["key"]],
     frame = data[["frame"]],

tests/testthat/test-ggplot-bar.R

@@ -21,22 +21,35 @@ researchers <- data.frame(
 
 gg <- ggplot(researchers, aes(country, papers, fill = field))
 
-test_that("position_dodge is translated to barmode=stack", {
+test_that("position_dodge()", {
   gg.dodge <- gg + geom_bar(stat = "identity", position = "dodge")
   info <- expect_traces(gg.dodge, 2, "dodge")
-  expect_identical(info$layout$barmode, "stack")
+  expect_identical(info$layout$barmode, "relative")
+  
+  l <- ggplotly(gg.dodge, dynamicTicks = "x")$x
+  expect_identical(l$layout$barmode, "dodge")
+  expect_equal(l$data[[1]]$x, c("Canada", "USA"))
+  expect_equal(l$data[[1]]$name, "Math")
+  expect_equal(l$data[[2]]$x, c("Canada", "Germany"))
+  expect_equal(l$data[[2]]$name, "Bio")
 })
 
-test_that("position_stack is translated to barmode=stack", {
+test_that("position_stack()", {
   gg.stack <- gg + geom_bar(stat = "identity", position = "stack")
   info <- expect_traces(gg.stack, 2, "stack")
-  expect_identical(info$layout$barmode, "stack")
+  expect_identical(info$layout$barmode, "relative")
+  
+  l <- ggplotly(gg.stack, dynamicTicks = T)$x
+  expect_identical(l$layout$barmode, "relative")
 })
 
-test_that("position_identity is translated to barmode=overlay", {
+test_that("position_identity()", {
   gg.identity <- gg + geom_bar(stat = "identity", position = "identity")
   info <- expect_traces(gg.identity, 2, "identity")
-  expect_identical(info$layout$barmode, "overlay")
+  expect_identical(info$layout$barmode, "relative")
+  
+  l <- ggplotly(gg.identity, dynamicTicks = T)$x
+  expect_identical(l$layout$barmode, "relative")
 })
 
 test_that("dates work well with bar charts", {
@@ -45,10 +58,23 @@ test_that("dates work well with bar charts", {
   gd <- ggplot(researchers, aes(month, papers, fill = field)) +
     geom_bar(stat = "identity")
   info <- expect_traces(gd, 2, "dates")
-  trs <- info$data
-  # plotly likes time in milliseconds
-  t <- as.numeric(unique(researchers$month)) * 24 * 60 * 60 * 1000
-  expect_equal(trs[[1]]$x, t)
+  
+  # by default, date axes are linear...
+  expect_equal(info$layout$xaxis$type, "linear")
+  expect_equal(
+    info$data[[1]]$x,
+    as.numeric(unique(researchers$month))
+  )
+  
+  # different story for dynamicTicks...
+  l <- ggplotly(gd, dynamicTicks = TRUE)$x
+  expect_equal(l$layout$xaxis$type, "date")
+  expect_equal(l$layout$xaxis$tickmode, "auto")
+  expect_is(l$layout$xaxis$range, "POSIXct")
+  for (attr in c("x", "base", "width")) {
+    expect_is(l$data[[1]][[attr]], "POSIXct")
+  }
+  
 })
 
 ## http://www.cookbook-r.com/Graphs/Bar_and_line_graphs_%28ggplot2%29/
@@ -117,7 +143,7 @@ base <- ggplot(mtcars, aes(factor(vs), fill = factor(cyl)))
 
 test_that("geom_bar() stacks counts", { 
   info <- expect_traces(base + geom_bar(), 3, "position-stack")
-  expect_identical(info$layout$barmode, "stack")
+  expect_identical(info$layout$barmode, "relative")
   trs <- info$data
   # sum of y values for each trace 
   test <- as.numeric(sort(sapply(trs, function(x) sum(x$y))))
@@ -127,7 +153,7 @@ test_that("geom_bar() stacks counts", {
 
 test_that("geom_bar(position = 'fill') stacks proportions", {
   info <- expect_traces(base + geom_bar(position = "fill"), 3, "position-fill")
-  expect_identical(info$layout$barmode, "stack")
+  expect_identical(info$layout$barmode, "relative")
   trs <- info$data
   # sum of y-values *conditioned* on a x-value
   prop <- sum(sapply(sapply(trs, "[[", "y"), "[", 1))

tests/testthat/test-ggplot-boxplot.R

@@ -36,7 +36,7 @@ test_that("you can make a boxplot for a distribution of datetimes", {
 
   expect_equal(length(L$data), 1)  # 1 trace
   expect_identical(L$data[[1]]$type, "box")
-  expect_identical(L$data[[1]]$y, as.numeric(df$y) * 1000)
+  expect_identical(L$data[[1]]$y, as.numeric(df$y))
 })
 
 # check legend shows up when each box-and-whiskers has a fill

tests/testthat/test-ggplot-date.R

@@ -11,7 +11,7 @@ test_that("datetimes are converted to e.g. 2013-01-02 05:00:00", {
   info <- save_outputs(gg, "date-strings")
   expect_equal(length(info$data), 2)
   for(trace in info$data[1:2]){
-    expect_equal(as.numeric(time.obj) * 1000, trace$x)
+    expect_equal(as.numeric(time.obj), trace$x)
   }
 })
 

tests/testthat/test-ggplot-histogram.R

@@ -16,15 +16,14 @@ base <- ggplot(mtcars, aes(wt))
 
 test_that("geom_histogram() is a bar chart of counts with no bargap", { 
   info <- expect_traces(base + geom_histogram(), 1, "counts")
-  expect_identical(info$layout$bargap, 0)
   tr <- info$data[[1]]
   expect_identical(tr$type, "bar")
   expect_equal(sum(tr$y), nrow(mtcars))
+  expect_equal(info$layout$barmode, "relative")
 })
 
 test_that("geom_histogram(aes(y = ..density..)) displays a density", { 
   info <- expect_traces(base + geom_histogram(aes(y=..density..)), 1, "density")
-  expect_identical(info$layout$bargap, 0)
   tr <- info$data[[1]]
   expect_identical(tr$type, "bar")
   #default binwidth
@@ -65,24 +64,23 @@ test_that("Specify histogram binwidth", {
 test_that("geom_histogram(aes(fill = factor(...))) is a stacked by default", {
   gg <- base + geom_histogram(aes(fill = factor(vs)))
   info <- expect_traces(gg, 2, "fill-factor")
-  expect_equal(info$layout$bargap, 0)
-  expect_equal(info$layout$barmode, "stack")
+  expect_equal(info$layout$barmode, "relative")
 })
 
 test_that("geom_histogram(aes(fill = factor(...))) respects position_identity()", {
-  gg <- base + geom_histogram(aes(fill = factor(vs)), alpha = 0.3,
-                              position = "identity")
+  gg <- base + geom_histogram(
+    aes(fill = factor(vs)), alpha = 0.3, position = "identity"
+  )
   info <- expect_traces(gg, 2, "fill-factor-identity")
-  expect_equal(info$layout$bargap, 0)
-  expect_equal(info$layout$barmode, "overlay")
+  expect_equal(info$layout$barmode, "relative")
 })
 
 test_that("geom_histogram(aes(fill = factor(...))) respects position_dodge()", {
-  gg <- base + geom_histogram(aes(fill = factor(vs)), alpha = 0.3,
-                              position = "dodge")
+  gg <- base + geom_histogram(
+    aes(fill = factor(vs)), alpha = 0.3, position = "dodge"
+  )
   info <- expect_traces(gg, 2, "fill-factor-dodge")
-  expect_equal(info$layout$bargap, 0)
-  expect_equal(info$layout$barmode, "stack")
+  expect_equal(info$layout$barmode, "relative")
 })
 
 test_that("geom_histogram() with facets", {
@@ -94,8 +92,7 @@ test_that("geom_histogram() with facets", {
   gap <- unique(sapply(trs, "[[", "bargap"))
   barmode <- unique(sapply(trs, "[[", "barmode"))
   expect_identical(type, "bar")
-  expect_equal(info$layout$bargap, 0)
-  expect_equal(info$layout$barmode, "stack")
+  expect_equal(info$layout$barmode, "relative")
 })
 
 test_that("vline overlaid histogram", {

tests/testthat/test-ggplot-lines.R

@@ -58,33 +58,27 @@ test_that("Translates both dates and datetimes (with dynamic ticks) correctly",
 
   p <- ggplot(d, aes(date, value)) + geom_line()
   l <- plotly_build(ggplotly(p, dynamicTicks = TRUE))$x
-  
-  milliseconds <- as.numeric(d$date) * 86400000
-  
+
   d2 <- data.frame(
     value = rnorm(100),
     date = as.POSIXct(dates)
   )
 
-  milliseconds2 <- as.numeric(d2$date) * 1000
   p2 <- ggplot(d2, aes(date, value)) + geom_line()
   l2 <- plotly_build(ggplotly(p2, dynamicTicks = TRUE))$x
 
-  # data is all on millisecond level
-  expect_equal(milliseconds, milliseconds2)
-  expect_equal(milliseconds, l$data[[1]]$x)
-  expect_equal(milliseconds, l2$data[[1]]$x)
-  
-  # same with range
-  expect_equal(grDevices::extendrange(milliseconds), l$layout$xaxis$range)
-  expect_equal(grDevices::extendrange(milliseconds), l2$layout$xaxis$range)
-  
   # since these are dynamic ticks, let plotly.js generate the ticks
   axisType <- with(l$layout$xaxis, list(type, tickmode, autorange))
   expect_equal(axisType, list("date", "auto", TRUE))
   axisType2 <- with(l2$layout$xaxis, list(type, tickmode, autorange))
   expect_equal(axisType2, list("date", "auto", TRUE))
 
+  # range and data have been reverse transformed
+  expect_is(l$layout$xaxis$range, "POSIXct")
+  expect_is(l$data[[1]]$x, "POSIXct")
+  expect_is(l2$layout$xaxis$range, "POSIXct")
+  expect_is(l2$data[[1]]$x, "POSIXct")
+  
   # check the hovertext
   dates1 <- sapply(strsplit(l$data[[1]]$text, br()), "[[", 1)
   dates2 <- sapply(strsplit(l2$data[[1]]$text, br()), "[[", 1)

tests/testthat/test-ggplot-point.R

@@ -55,5 +55,5 @@ test_that("can plot on sub-second time scale", {
   )
   g <- ggplot(d, aes(x, y)) + geom_point()
   info <- save_outputs(g, "point-size-alpha2")
-  expect_equivalent(info$data[[1]]$x, as.numeric(d$x) * 1000)
+  expect_equivalent(info$data[[1]]$x, as.numeric(d$x))
 })