Feature/labels

DESCRIPTION

@@ -22,7 +22,7 @@ URL: https://plot.ly/r, https://cpsievert.github.io/plotly_book/, https://github
 BugReports: https://github.com/ropensci/plotly/issues
 Depends:
     R (>= 3.2.0),
-    ggplot2 (>= 2.2.1)
+    ggplot2 (> 2.2.1)
 Imports:
     tools,
     scales,

R/highlight.R

@@ -122,7 +122,6 @@ highlight <- function(p, on = "plotly_click", off,
     p$dependencies <- c(p$dependencies, list(colourPickerLib()))
   }
 
-
   # TODO: expose unhover?
   off_options <- paste0(
     "plotly_", c("doubleclick", "deselect", "relayout")

R/layers2traces.R

@@ -79,7 +79,6 @@ layers2traces <- function(data, prestats_data, layout, p) {
   # 2. geom_smooth() is really geom_path() + geom_ribbon()
   datz <- list()
   paramz <- list()
-  layout <- if (is_dev_ggplot2()) layout else list(layout = layout)
   for (i in seq_along(data)) {
     # This has to be done in a loop, since some layers are really two layers,
     # (and we need to replicate the data/params in those cases)
@@ -387,7 +386,7 @@ to_basic.GeomAbline <- function(data, prestats_data, layout, params, p, ...) {
   data$group <- interaction(
     data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
   )
-  lay <- tidyr::gather_(layout$layout, "variable", "x", c("x_min", "x_max"))
+  lay <- tidyr::gather_(layout$layout, "variable", "x", c("xmin", "xmax"))
   data <- merge(lay[c("PANEL", "x")], data, by = "PANEL")
   data[["y"]] <- with(data, intercept + slope * x)
   prefix_class(data, c("GeomHline", "GeomPath"))
@@ -399,7 +398,7 @@ to_basic.GeomHline <- function(data, prestats_data, layout, params, p, ...) {
   data$group <- do.call(paste,
     data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
   )
-  lay <- tidyr::gather_(layout$layout, "variable", "x", c("x_min", "x_max"))
+  lay <- tidyr::gather_(layout$layout, "variable", "x", c("xmin", "xmax"))
   data <- merge(lay[c("PANEL", "x")], data, by = "PANEL")
   data[["y"]] <- data$yintercept
   prefix_class(data, c("GeomHline", "GeomPath"))
@@ -411,7 +410,7 @@ to_basic.GeomVline <- function(data, prestats_data, layout, params, p, ...) {
   data$group <- do.call(paste,
     data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
   )
-  lay <- tidyr::gather_(layout$layout, "variable", "y", c("y_min", "y_max"))
+  lay <- tidyr::gather_(layout$layout, "variable", "y", c("ymin", "ymax"))
   data <- merge(lay[c("PANEL", "y")], data, by = "PANEL")
   data[["x"]] <- data$xintercept
   prefix_class(data, c("GeomVline", "GeomPath"))
@@ -428,7 +427,7 @@ to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, p, ...) {
   # width for ggplot2 means size of the entire bar, on the data scale
   # (plotly.js wants half, in pixels)
   data <- merge(data, layout$layout, by = "PANEL", sort = FALSE)
-  data$width <- (data[["xmax"]] - data[["x"]]) /(data[["x_max"]] - data[["x_min"]])
+  data$width <- (data[["xmax"]] - data[["x"]]) /(data[["xmax"]] - data[["xmin"]])
   data$fill <- NULL
   prefix_class(data, "GeomErrorbar")
 }
@@ -438,7 +437,7 @@ to_basic.GeomErrorbarh <- function(data, prestats_data, layout, params, p, ...)
   # height for ggplot2 means size of the entire bar, on the data scale
   # (plotly.js wants half, in pixels)
   data <- merge(data, layout$layout, by = "PANEL", sort = FALSE)
-  data$width <- (data[["ymax"]] - data[["y"]]) / (data[["y_max"]] - data[["y_min"]])
+  data$width <- (data[["ymax"]] - data[["y"]]) / (data[["ymax"]] - data[["ymin"]])
   data$fill <- NULL
   prefix_class(data, "GeomErrorbarh")
 }
@@ -476,11 +475,11 @@ to_basic.GeomPointrange <- function(data, prestats_data, layout, params, p, ...)
 #' @export
 to_basic.GeomDotplot <- function(data, prestats_data, layout, params, p, ...) {
   if (identical(params$binaxis, "y")) {
-    dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$y_max - layout$layout$y_min)
+    dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$ymax - layout$layout$ymin)
     data$size <- as.numeric(grid::convertHeight(grid::unit(dotdia, "npc"), "mm")) / 2
     data$x <- (data$countidx - 0.5) * (as.numeric(dotdia) * 6)
   } else {
-    dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$x_max - layout$layout$x_min)
+    dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$xmax - layout$layout$xmin)
     data$size <- as.numeric(grid::convertWidth(grid::unit(dotdia, "npc"), "mm")) / 2
     # TODO: why times 6?!?!
     data$y <- (data$countidx - 0.5) * (as.numeric(dotdia) * 6)
@@ -516,9 +515,9 @@ utils::globalVariables(c("xmin", "xmax", "y", "size"))
 to_basic.GeomRug  <- function(data, prestats_data, layout, params, p, ...) {
   # allow the tick length to vary across panels
   layout <- layout$layout
-  layout$tickval_y <- 0.03 * abs(layout$y_max - layout$y_min)
-  layout$tickval_x <- 0.03 * abs(layout$x_max - layout$x_min)
-  data <- merge(data, layout[c("PANEL", "x_min", "x_max", "y_min", "y_max", "tickval_y", "tickval_x")])
+  layout$tickval_y <- 0.03 * abs(layout$ymax - layout$ymin)
+  layout$tickval_x <- 0.03 * abs(layout$xmax - layout$xmin)
+  data <- merge(data, layout[c("PANEL", "xmin", "xmax", "ymin", "ymax", "tickval_y", "tickval_x")])
 
   # see GeomRug$draw_panel()
   rugs <- list()
@@ -530,8 +529,8 @@ to_basic.GeomRug  <- function(data, prestats_data, layout, params, p, ...) {
         data, data.frame(
           x = x, 
           xend = x,
-          y = y_min, 
-          yend = y_min + tickval_y,
+          y = ymin, 
+          yend = ymin + tickval_y,
           others
         )
       )
@@ -541,8 +540,8 @@ to_basic.GeomRug  <- function(data, prestats_data, layout, params, p, ...) {
         data, data.frame(
           x = x, 
           xend = x,
-          y = y_max - tickval_y, 
-          yend = y_max,
+          y = ymax - tickval_y, 
+          yend = ymax,
           others
         )
       )
@@ -552,8 +551,8 @@ to_basic.GeomRug  <- function(data, prestats_data, layout, params, p, ...) {
     if (grepl("l", sides)) {
       rugs$l <- with(
         data, data.frame(
-          x = x_min, 
-          xend = x_min + tickval_x,
+          x = xmin, 
+          xend = xmin + tickval_x,
           y = y, 
           yend = y,
           others
@@ -563,8 +562,8 @@ to_basic.GeomRug  <- function(data, prestats_data, layout, params, p, ...) {
     if (grepl("r", sides)) {
       rugs$r <- with(
         data, data.frame(
-          x = x_max - tickval_x, 
-          xend = x_max,
+          x = xmax - tickval_x, 
+          xend = xmax,
           y = y, 
           yend = y,
           others

R/plotly.R

@@ -350,7 +350,8 @@ as_widget <- function(x, ...) {
     sizingPolicy = htmlwidgets::sizingPolicy(
       browser.fill = TRUE,
       defaultWidth = '100%',
-      defaultHeight = 400
+      defaultHeight = 400,
+      padding = 0
     ),
     preRenderHook = plotly_build,
     dependencies = c(

R/utils.R

@@ -73,7 +73,7 @@ to_milliseconds <- function(x) {
 retain <- function(x, f = identity) {
   y <- structure(f(x), class = oldClass(x))
   attrs <- attributes(x)
-  # TODO: do we set any other "special" attributes internally 
+  # TODO: do we set any other "special" attributes internally?
   # (grepping "structure(" suggests no)
   attrs <- attrs[names(attrs) %in% c("defaultAlpha", "apiSrc")]
   if (length(attrs)) {

inst/htmlwidgets/plotly.js

@@ -15,13 +15,17 @@ HTMLWidgets.widget({
   },
 
   resize: function(el, width, height, instance) {
+
+    var gd = document.getElementById(el.id);
+
     if (instance.autosize) {
       var width = instance.width || width;
       var height = instance.height || height;
-      Plotly.relayout(el.id, {width: width, height: height});
+      Plotly.relayout(gd, {width: width, height: height});
+      ggplotlyAdjustLabels(gd);
     }
   },  
-  
+
   renderValue: function(el, x, instance) {
 
     if (typeof(window) !== "undefined") {
@@ -159,8 +163,11 @@ HTMLWidgets.widget({
 
     }
 
-    // Trigger plotly.js calls defined via `plotlyProxy()`
-    plot.then(function() {
+    plot.then(function(gd) {
+
+      ggplotlyAdjustLabels(gd);
+
+      // Trigger plotly.js calls defined via `plotlyProxy()`
       if (HTMLWidgets.shinyMode) {
         Shiny.addCustomMessageHandler("plotly-calls", function(msg) {
           var gd = document.getElementById(msg.id);
@@ -174,6 +181,7 @@ HTMLWidgets.widget({
           Plotly[msg.method].apply(null, args);
         });
       }
+
     });
 
     // Attach attributes (e.g., "key", "z") to plotly event data
@@ -375,7 +383,8 @@ HTMLWidgets.widget({
           selectize.addItems(e.value, true);
           selectize.close();
         }
-      }
+      };
+
       selection.on("change", selectionChange);
 
       // Set a crosstalk variable selection value, triggering an update
@@ -438,14 +447,7 @@ HTMLWidgets.widget({
           }
         });
       }
-
-
-
-
-
-
-
-
+
     }
 
   } // end of renderValue
@@ -821,3 +823,21 @@ function removeBrush(el) {
     outlines[i].remove();
   }
 }
+
+
+// for ggplotly labels, scale annotation height/width to match graph size
+function ggplotlyAdjustLabels(gd) {
+  var layout = gd.layout || {};
+  var anns = layout.annotations || [];
+  for (var i = 0; i < anns.length; i++) {
+    var container = {};
+    if (anns[i].ggplotlyDirection === "horizontal") {
+      container['annotations[' + i + '].width'] = gd._fullLayout._size.w;
+      Plotly.relayout(gd, container);
+    }
+    if (anns[i].ggplotlyDirection === "vertical") {
+      container['annotations[' + i + '].height'] = gd._fullLayout._size.h;
+      Plotly.relayout(gd, container);
+    }
+  }
+}

tests/testthat/test-ggplot-labels.R

@@ -5,6 +5,7 @@ test_that("ggtitle is translated correctly", {
     geom_point(aes(Petal.Width, Sepal.Width)) +
     ggtitle("My amazing plot!")
   info <- save_outputs(ggiris, "labels-ggtitle")
+  # TODO: change me to annotation to support justification
   expect_identical(info$layout$title, "My amazing plot!")
 })
 
@@ -17,15 +18,14 @@ test_that("ylab is translated correctly", {
   expect_identical(labs, c("Petal.Width", "sepal width"))
 })
 
-# TODO: why is this failing on R-devel???
-#test_that("scale_x_continuous(name) is translated correctly", {
-#  ggiris <- ggplot(iris) +
-#    geom_point(aes(Petal.Width, Sepal.Width)) +
-#    scale_x_continuous("petal width")
-#  info <- save_outputs(ggiris, "labels-scale_x_continuous_name")
-#  labs <- unlist(lapply(info$layout$annotations, "[[", "text"))
-#  expect_identical(sort(labs), c("petal width", "Sepal.Width"))
-#})
+test_that("scale_x_continuous(name) is translated correctly", {
+  ggiris <- ggplot(iris) +
+    geom_point(aes(Petal.Width, Sepal.Width)) +
+    scale_x_continuous("petal width")
+  info <- save_outputs(ggiris, "labels-scale_x_continuous_name")
+  labs <- c(info$layout$xaxis$title, info$layout$yaxis$title)
+  expect_identical(labs, c("petal width", "Sepal.Width"))
+})
 
 test_that("angled ticks are translated correctly", {
   ggiris <- ggplot(iris) +
@@ -34,3 +34,43 @@ test_that("angled ticks are translated correctly", {
   info <- save_outputs(ggiris, "labels-angles")
   expect_identical(info$layout$xaxis$tickangle, -45)
 })
+
+test_that("labels are translated correctly", {
+  ggiris <- ggplot(iris) +
+    geom_point(aes(Petal.Width, Sepal.Width)) +
+    ggtitle("My amazing plot!") +
+    labs(
+      subtitle = "Some loooooooooooooooooooooooooooooooooooooooooooooong text",
+      caption = "Some loooooooooooooooooooooooooooong text"
+    )
+  info <- save_outputs(ggiris, "labels-ggtitle")
+  # TODO: change me to annotation to support justification
+  expect_identical(info$layout$title, "My amazing plot!")
+})
+
+# TODO: why is the right plot margin off?
+ggplotly(qplot(data = mtcars, vs, mpg))
+
+# TODO: 
+# (1) how to handle text being clipped to the width?
+# (2) test lineheight once we have a ability to set it
+
+qplot(data = mtcars, vs, mpg, color = factor(am)) +
+  labs(
+    title = "sadlknewldknewflkcewelkmcdewdlm;dscklmcdslkmcds",
+    subtitle = "Some looooooooooooo0000000000000000oooooooooooooooooooooooooooong text",
+    caption = "Some loooooooooooooooooooooooooooong text",
+    x = "Silly",
+    y = "Yar har har"
+  ) +
+  theme(
+    plot.title = element_text(hjust = 0.5, debug = TRUE),
+    plot.subtitle = element_text(hjust = 0.5, size = 20, debug = TRUE),
+    plot.caption = element_text(debug = TRUE),
+    axis.title.x = element_text(hjust = 0.5, vjust = 0.75, angle = 90, debug = TRUE),
+    axis.title.y = element_text(hjust = 0.5, vjust = 0.25, angle = 45, debug = TRUE),
+    # TODO: why doesn't debug get respected here?
+    legend.title = element_text(size = 7, debug = TRUE),
+    # TODO: 
+    legend.title.align = 0.5
+  )

tests/testthat/test-ggplot2-api.R

@@ -0,0 +1,19 @@
+context("ggplot-api")
+
+
+test_that("summarise_layout() gives the expected summary", {
+  p <- ggplot(mpg, aes(displ, hwy)) + geom_point() + facet_wrap(drv ~ cyl)
+  built <- ggplot_build(p)
+  layout <- summarise_layout(built)
+
+  expect_true(nrow(layout) == 9)
+  expect_equal(lengths(layout$vars), rep(2, 9))
+  # we access most (if not all) of these variables in the summary
+  expect_length(
+    setdiff(
+      c('panel', 'row', 'col', 'vars', 'xmin', 'xmax', 'ymin', 'ymax', 'xscale', 'yscale'),
+      names(layout)
+    ), 0
+  )
+
+})