Merge pull request #508 from ropensci/fix/facetLabeller

Fix/facet labeller

Author: cpsievert

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: plotly
 Title: Create Interactive Web Graphics via 'plotly.js'
-Version: 3.4.2
+Version: 3.4.3
 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"),
     email = "cpsievert1@gmail.com"),
     person("Chris", "Parmer", role = c("aut", "cph"),

NEWS

@@ -1,10 +1,15 @@
+3.4.3 -- 14 Mar 2016
+
+BUGFIX:
+
+Custom facet labeller functions will now translate correctly. See #507.
+
 3.4.2 -- 14 Mar 2016
 
 BUGFIX:
 
 Automatic resizing will now occur only when layout.autosize is true (the default). See #403.
 
-
 3.4.1 -- 13 Mar 2016
 
 BUGFIX:

R/ggplotly.R

@@ -303,6 +303,7 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
     rep(panelMarginX, 2),
     rep(panelMarginY, 2)
   )
+  
   doms <- get_domains(nPanels, nRows, margins)
 
   for (i in seq_len(nPanels)) {
@@ -428,12 +429,11 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
     gglayout$shapes <- c(gglayout$shapes, border)
 
     # facet strips -> plotly annotations
-    # TODO: use p$facet$labeller for the actual strip text!
     if (!is_blank(theme[["strip.text.x"]]) &&
         (inherits(p$facet, "wrap") || inherits(p$facet, "grid") && lay$ROW == 1)) {
       vars <- ifelse(inherits(p$facet, "wrap"), "facets", "cols")
       txt <- paste(
-        lay[, as.character(p$facet[[vars]])], collapse = ", "
+        p$facet$labeller(lay[names(p$facet[[vars]])]), collapse = ", "
       )
       lab <- make_label(
         txt, x = mean(xdom), y = max(ydom),
@@ -447,7 +447,7 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
     if (inherits(p$facet, "grid") && lay$COL == nCols && nRows > 1 &&
         !is_blank(theme[["strip.text.y"]])) {
       txt <- paste(
-        lay[, as.character(p$facet$rows)], collapse = ", "
+        p$facet$labeller(lay[names(p$facet$rows)]), collapse = ", "
       )
       lab <- make_label(
         txt, x = max(xdom), y = mean(ydom),

tests/testthat/test-ggplot-facets.R

@@ -97,3 +97,27 @@ test_that("facet_wrap() doesn't create interior scales", {
   info <- save_outputs(g, "facet_wrap")
   expect_equal(unique(unlist(lapply(info$data, "[[", "yaxis"))), "y")
 })
+
+
+g <- ggplot(mtcars, aes(mpg, wt)) + 
+  geom_point() +
+  facet_wrap( ~ am, labeller = label_both)
+
+test_that("facet_wrap translates simple labeller function", {
+  info <- save_outputs(g, "facet_wrap-labeller")
+  txt <- sapply(info$layout$annotations, "[[", "text")
+  expect_true(all(c("am: 0", "am: 1") %in% txt))
+})
+
+g <- ggplot(mtcars, aes(mpg, wt)) + 
+  geom_point() +
+  facet_grid(vs ~ am, labeller = label_both)
+
+test_that("facet_grid translates simple labeller function", {
+  info <- save_outputs(g, "facet_grid-labeller")
+  txt <- sapply(info$layout$annotations, "[[", "text")
+  expect_true(
+    all(c("am: 0", "am: 1", "vs: 0", "vs: 1") %in% txt)
+  )
+})
+