also consider layer/stat specific aes mappings

Author: cpsievert

R/ggplotly.R

@@ -173,43 +173,61 @@ gg2list <- function(p, width = NULL, height = NULL, mapping = "all", source = "A
   panel$layout$x_max <- sapply(panel$ranges, function(z) max(z$x.range))
   panel$layout$y_min <- sapply(panel$ranges, function(z) min(z$y.range))
   panel$layout$y_max <- sapply(panel$ranges, function(z) max(z$y.range))
-
-  # use aes mappings for the tooltip default
-  aesMap <- as.character(p$mapping)
-  if (!identical(mapping, "all")) {
-    aesMap <- aesMap[names(aesMap) %in% mapping]
-    aesMap <- aesMap[mapping]
-  }
-  # tooltips for discrete positional scales are misleading
-  for (xy in c("x", "y")) {
-    if (scales$get_scales(xy)$is_discrete()) {
-      aesMap <- aesMap[names(aesMap) != xy]
+  
+  # --------------------------------------------------------------------
+  # Use aes mappings for sensible tooltips
+  # --------------------------------------------------------------------
+  
+  aesMap <- lapply(p$layers, function(x) { 
+    map <- c(
+      # plot level aes mappings
+      as.character(p$mapping), 
+      # layer level mappings
+      as.character(x$mapping), 
+      # stat specific mappings
+      as.character(x$stat$default_aes)
+    )
+    # remove leading/trailing dots in "hidden" stat aes
+    map <- sub("^\\.\\.", "", sub("\\.\\.$", "", map))
+    # TODO: allow users to specify a _list_ of mappings?
+    if (!identical(mapping, "all")) {
+      map <- map[names(map) %in% mapping]
     }
-  }
+    # tooltips for discrete positional scales are misleading
+    if (scales$get_scales("x")$is_discrete()) {
+      map <- map[!names(map) %in% "x"]
+    }
+    if (scales$get_scales("y")$is_discrete()) {
+      map <- map[!names(map) %in% "y"]
+    }
+    map
+  })
 
-  for (i in seq_along(aesMap)) {
-    aesName <- names(aesMap)[[i]]
-    # TODO: should we be getting the name from scale_*(name) first?
-    varName <- aesMap[[i]]
-    # by default assume the values don't need any formatting
-    forMat <- function(x) if (is.numeric(x)) round(x, 2) else x
-    if (aesName %in% c("x", "y")) {
-      scaleName <- scales$get_scales(aesName)$scale_name
-      # convert "milliseconds from the UNIX epoch" back to a date/datetime
-      # http://stackoverflow.com/questions/13456241/convert-unix-epoch-to-date-object-in-r
-      if ("date" %in% scaleName) forMat <- function(x) as.Date(as.POSIXct(x / 1000, origin = "1970-01-01"))
-      if ("datetime" %in% scaleName) forMat <- function(x) as.POSIXct(x / 1000, origin = "1970-01-01")
-    } else {
-      if (aesName != "text") aesName <- paste0(aesName, "_plotlyDomain")
+  # attach a new column (hovertext) to each layer of data that should get mapped
+  # to the text trace property
+  data <- Map(function(x, y) {
+    for (i in seq_along(y)) {
+      aesName <- names(y)[[i]]
+      # TODO: should we be getting the name from scale_*(name) first?
+      varName <- y[[i]]
+      # by default assume the values don't need any formatting
+      forMat <- function(x) if (is.numeric(x)) round(x, 2) else x
+      if (aesName %in% c("x", "y")) {
+        scaleName <- scales$get_scales(aesName)$scale_name
+        # convert "milliseconds from the UNIX epoch" back to a date/datetime
+        # http://stackoverflow.com/questions/13456241/convert-unix-epoch-to-date-object-in-r
+        if ("date" %in% scaleName) forMat <- function(x) as.Date(as.POSIXct(x / 1000, origin = "1970-01-01"))
+        if ("datetime" %in% scaleName) forMat <- function(x) as.POSIXct(x / 1000, origin = "1970-01-01")
+      } else {
+        if (aesName != "text") aesName <- paste0(aesName, "_plotlyDomain")
+      }
+      # add a line break if hovertext already exists
+      if ("hovertext" %in% names(x)) x$hovertext <- paste0(x$hovertext, "<br>")
+      x$hovertext <- paste0(x$hovertext, varName, ": ", forMat(x[[aesName]]))
     }
-    
-    data <- lapply(data, function(d) {
-      if (!is.null(d$hovertext)) d$hovertext <- paste0(d$hovertext, "<br>")
-      d$hovertext <- paste0(d$hovertext, varName, ": ", forMat(d[[aesName]]))
-      d
-    })
-  }
-
+    x
+  }, data, aesMap)
+  
   # layers -> plotly.js traces
   traces <- layers2traces(
     data, prestats_data, layers, panel$layout, scales, p$labels

R/layers2traces.R

@@ -202,19 +202,16 @@ to_basic.GeomRect <- function(data, prestats_data, layout, params, ...) {
 
 #' @export
 to_basic.GeomRaster <- function(data, prestats_data, layout, params, ...) {
-  data$z <- prestats_data$fill
-  if (is.discrete(prestats_data$fill)) {
-    data <- prefix_class(data, "GeomRect")
-    to_basic(data, prestats_data, layout, params)
-  } else {
-    prefix_class(data, "GeomTile")
-  }
+  data <- prefix_class(data, "GeomTile")
+  to_basic(data, prestats_data, layout, params)
 }
 
 #' @export
 to_basic.GeomTile <- function(data, prestats_data, layout, params, ...) {
-  data$z <- prestats_data$fill
-  if (is.discrete(prestats_data$fill)) {
+  # geom2trace.GeomTile is a heatmap, which requires continuous fill and 
+  # a complete grid
+  g <- expand.grid(unique(data$x), unique(data$y))
+  if (nrow(g) != nrow(data) || is.discrete(prestats_data$fill)) {
     data <- prefix_class(data, "GeomRect")
     to_basic(data, prestats_data, layout, params)
   } else {
@@ -416,14 +413,10 @@ geom2trace.GeomBar <- function(data, params) {
 #' @export
 geom2trace.GeomPolygon <- function(data, params) {
   data <- group2NA(data)
-  # TODO: do this for more density-like measures??
-  if ("level" %in% names(data)) {
-    data$level <- paste("Level:", data$level)
-  }
   L <- list(
     x = data$x,
     y = data$y,
-    text = data$hovertext %||% data$level,
+    text = data$hovertext,
     type = "scatter",
     mode = "lines",
     line = list(
@@ -501,16 +494,24 @@ geom2trace.GeomTile <- function(data, params) {
   data <- data[order(data$x, order(data$y, decreasing = T)), ]
   x <- sort(unique(data$x))
   y <- sort(unique(data$y))
+  fill <- data$fill_plotlyDomain
   colorscale <- cbind(
     c(0, 1),
-    data[c(which.min(data$z), which.max(data$z)), "fill"]
+    data[c(which.min(fill), which.max(fill)), "fill"]
   )
   list(
     x = x,
     y = y,
-    text = matrix(data$z, nrow = length(y), ncol = length(x)),
-    hoverinfo = "text",
-    z = matrix(scales::rescale(data$z), nrow = length(y), ncol = length(x)),
+    z = matrix(
+      scales::rescale(fill), 
+      nrow = length(y), 
+      ncol = length(x)
+    ),
+    text = matrix(
+      data$hovertext, 
+      nrow = length(y), 
+      ncol = length(x)
+    ),
     colorscale = colorscale,
     type = "heatmap",
     showscale = FALSE,

man/gg2list.Rd

@@ -20,4 +20,11 @@ test_that("geom_tile is translated to type=heatmap", {
   expect_identical(L$data[[1]]$type, "heatmap")
   expect_identical(L$layout$xaxis$ticktext, wdays)
   expect_identical(L$layout$yaxis$ticktext, dtimes)
+  # show bin value on hover (but without x/y since they are discrete)
+  expect_true(
+    L$data[[1]]$hoverinfo == "text"
+  )
+  expect_true(
+    all(grepl("^value: [-]?[0-9]+$", c(L$data[[1]]$text)))
+  )
 })