add hide_legend and hide_guides to complement hide_colorbar

Author: cpsievert

NAMESPACE

@@ -91,6 +91,8 @@ export(group_by_.plotly)
 export(groups)
 export(groups.plotly)
 export(hide_colorbar)
+export(hide_guides)
+export(hide_legend)
 export(knit_print.plotly_figure)
 export(last_plot)
 export(layout)

R/crosstalk.R

@@ -0,0 +1,41 @@
+# #' Control selection appearance
+# #' 
+# #' Control the visual appearance of selections deriving from a given
+# #' selection set.
+# #' 
+# #' @param dynamic should UI controls for managing selection aesthetics be 
+# #' included in the output?
+# #' @param persistant should selections persist (i.e., accumulate)?
+# #' @param color color(s) to use for highlighting selections. 
+# #' If \code{NULL} (the default), the color of selections are not altered. 
+# #' If not \code{NULL}
+# #' a valid color code,  
+# #' If not \code{dynamic}, this argument should be length 1,
+# #' If \code{dynamic},
+# #' this argument accepts a character
+# #' @param opacityDim a number between 0 and 1 used to reduce the
+# #' opacity of non-selected traces (by multiplying with the existing opacity).
+# #' @param showInLegend show a legend entry for additional "selection traces"?
+# #' @export
+# #' 
+# 
+# ct_opts <- function(dynamic = FALSE, persitant = dynamic, color = NULL,
+#                     opacityDim = 0.2, showInLegend = FALSE) {
+#   if (opacityDim < 0 || 1 < opacityDim) {
+#     stop("opacityDim must be between 0 and 1", call. = FALSE)
+#   }
+#   if (dynamic && length(color) < 2) {
+#     message("Adding more colors to the selection color palette")
+#     color <- c(color, RColorBrewer::brewer.pal(8, "Set2"))
+#   }
+#   if (!dynamic) {
+#    color <- color[1] 
+#   }
+#   list(
+#     color = toRGB(color),
+#     dynamic = dynamic,
+#     persitant = persitant,
+#     opacityDim = opacityDim,
+#     showInLegend = showInLegend
+#   )
+# }

R/ggplotly.R

@@ -550,7 +550,9 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all",
         y = gglayout$legend$y %||% 1,
         theme$legend.title,
         xanchor = "left",
-        yanchor = "top"
+        yanchor = "top",
+        # just so the R client knows this is a title
+        legendTitle = TRUE
       )
       gglayout$annotations <- c(gglayout$annotations, titleAnnotation)
       # adjust the height of the legend to accomodate for the title

R/helpers.R

@@ -1,8 +1,21 @@
-#' Hide a color bar 
+#' Hide guides (legends and colorbars)
+#'
+#' @param p a plotly object.
+#' @export
+#' @seealso \link{hide_legend}, \link{hide_colorbar}
+#'
+
+hide_guides <- function(p) {
+  hide_legend(hide_colorbar(p))
+}
+
+
+#' Hide color bar(s)
 #' 
 #' @param p a plotly object.
 #' @export
-#' @examples 
+#' @seealso \link{hide_legend}
+#' @examples
 #' 
 #' plot_ly(economics, x = ~date, y = ~unemploy / pop, color = ~pop) %>%
 #'   add_markers() %>%
@@ -21,6 +34,30 @@ hide_colorbar <- function(p) {
   p
 }
 
+#' Hide legend
+#' 
+#' @param p a plotly object.
+#' @export
+#' @seealso \link{hide_legend}
+#' @examples 
+#' 
+#' plot_ly(economics, x = ~date, y = ~unemploy / pop, color = ~pop) %>%
+#'   add_markers() %>%
+#'   hide_colorbar()
+
+hide_legend <- function(p) {
+  p <- plotly_build(p)
+  # annotations have to be an array of objects, so this should be a list of lists
+  ann <- p$x$layout$annotations
+  for (i in seq_along(ann)) {
+    if (isTRUE(ann[[i]]$legendTitle)) {
+      p$x$layout$annotations[[i]] <- NULL
+    }
+  }
+  p$x$layout$showlegend <- FALSE
+  p
+}
+
 #' Convert trace types to WebGL
 #' 
 #' @param p a plotly or ggplot object.

man/hide_colorbar.Rd

@@ -70,9 +70,26 @@ test_that("very long legend items", {
   )
   p_long_items <- ggplot(long_items, aes(cat1, fill = cat2)) + 
     geom_bar(position = "dodge")
-  info <- expect_traces(p_long_items, 3, "very long legend items")
+  info <- expect_traces(p_long_items, 3, "very-long-legend-items")
 })
 
+iris$All <- "All species"
+p <- qplot(data = iris, x = Sepal.Length, y = Sepal.Width, color = All)
+
+test_that("legend is created with discrete mapping regardless of unique values", {
+  info <- expect_traces(p, 1, "one-entry")
+  expect_true(info$data[[1]]$showlegend)
+  expect_true(info$layout$showlegend)
+  expect_equal(length(info$layout$annotations), 1)
+})
+
+test_that("can hide legend", {
+  info <- expect_traces(hide_legend(p), 1, "hide-legend")
+  expect_false(info$layout$showlegend)
+  expect_null(info$layout$annotations)
+})
+
+
 # test of legend position
 test_that("many legend items", {
   p <- ggplot(midwest, aes(category, fill = category)) + geom_bar()

man/hide_legend.Rd

@@ -5,7 +5,8 @@ gg <- ggplot(mtcars, aes(x = wt, y = mpg, label = rownames(mtcars))) +
 info <- save_outputs(gg, "text")
 
 test_that("label is translated correctly", {
-  expect_identical(as.character(info$data[[1]]$text), rownames(mtcars))
+  greps <- Map(function(x, y) grepl(x, y), rownames(mtcars), info$data[[1]]$text)
+  expect_true(all(unlist(greps)))
 })
 
 test_that("position is translated correctly", {

tests/testthat/test-ggplot-legend.R

@@ -68,3 +68,30 @@ test_that("group domain is included in hovertext", {
   pattern <- paste(unique(txhousing$city), collapse = "|")
   expect_true(all(grepl(pattern, txt)))
 })
+
+
+labelDF <- data.frame(
+  label = paste0(("label"), c(1:10)), 
+  x = runif(10, 1, 10), 
+  y = runif(10, 1, 10)
+)
+# Create data frame for 10 edges
+edgeDF <- data.frame(
+  x = runif(10, 1, 10), 
+  y = runif(10, 1, 10), 
+  xend = runif(10, 1, 10), 
+  yend = runif(10, 1, 10)
+)
+
+myPlot <- ggplot(data = labelDF, aes(x = x, y = y)) +
+  geom_segment(data = edgeDF, aes(x = x, y = y, xend = xend, yend = yend), 
+               colour = "pink") +
+  geom_text(data = labelDF, aes(x = x, y = y, label = label), size = 10)
+
+test_that("Hoverinfo is only displayed if no tooltip variables are present", {
+  L <- save_outputs(p, "hovertext-display")
+  L <- plotly_build(ggplotly(myPlot, tooltip = "label"))[["x"]]
+  expect_equal(length(L$data), 2)
+  expect_equal(sum(nchar(L$data[[1]]$text)), 0)
+  expect_true(all(grepl("^label:", L$data[[2]]$text)))
+})