WIP: Guide compatability with ggplot2 >3.4.2

R/guide_bins_interactive.R

@@ -11,8 +11,15 @@
 #' @example examples/scale_viridis_guide_bins_interactive.R
 #' @seealso [interactive_parameters], [girafe()]
 #' @export
-guide_bins_interactive <- function(...)
-  guide_interactive(guide_legend, "interactive_bins", ...)
+guide_bins_interactive <- function(...) {
+  guide <- guide_interactive(guide_legend, "interactive_bins", ...)
+  if (!inherits(guide, "Guide")) {
+    return(guide)
+  } else {
+    ggproto_legend_interactive(guide)
+  }
+}
+
 
 #' @export
 #' @importFrom purrr imap

R/guide_colourbar_interactive.R

@@ -11,8 +11,42 @@
 #' @example examples/scale_gradient_guide_colourbar_interactive.R
 #' @seealso [interactive_parameters], [girafe()]
 #' @export
-guide_colourbar_interactive <- function(...)
-  guide_interactive(guide_colourbar, "interactive_colourbar", ...)
+guide_colourbar_interactive <- function(..., .guide = NULL) {
+  guide <- guide_interactive(guide_colourbar, "interactive_colourbar", ...)
+  if (!inherits(guide, "Guide")) {
+    return(guide)
+  } else {
+    ggproto_colourbar_interactive(guide)
+  }
+}
+
+ggproto_colourbar_interactive <- function(guide) {
+  force(guide)
+  ggproto(
+    NULL, guide,
+    train = function(params, scale, aesthetic = NULL, ...) {
+      out <- guide$train(params, scale, aesthetic, ...)
+      if (!is.null(out)) {
+        out$.ipar <- ipar <- get_ipar(scale)
+        out$.interactive <- copy_interactive_attrs(scale, list(), ipar = ipar)
+      }
+      out
+    },
+    draw = function(theme, params) {
+      gtable <- guide$draw(theme, params)
+      ipar <- get_ipar(params)
+      data <- get_interactive_data(params)
+      # set them to the bar
+      barIndex <- which(gtable$layout$name == "bar")
+      gtable$grobs[[barIndex]] <-
+        add_interactive_attrs(gtable$grobs[[barIndex]],
+                              data,
+                              data_attr = "key-id",
+                              ipar = ipar)
+      gtable
+    }
+  )
+}
 
 #' @export
 #' @rdname guide_colourbar_interactive

R/guide_coloursteps_interactive.R

@@ -11,8 +11,15 @@
 #' @example examples/scale_viridis_guide_coloursteps_interactive.R
 #' @seealso [interactive_parameters], [girafe()]
 #' @export
-guide_coloursteps_interactive <- function(...)
-  guide_interactive(guide_coloursteps, "interactive_coloursteps", ...)
+guide_coloursteps_interactive <- function(...) {
+  guide <- guide_interactive(guide_coloursteps, "interactive_coloursteps", ...)
+  if (!inherits(guide, "Guide")) {
+    return(guide)
+  } else {
+    ggproto_colourbar_interactive(guide)
+  }
+}
+
 
 #' @export
 #' @rdname guide_coloursteps_interactive

R/guide_interactive.R

@@ -6,8 +6,12 @@ guide_interactive <- function(guide_func,
   args <- list(...)
   # Call default guide function
   guide <- do.call(guide_func, args)
-  class(guide) <- c(cl, "interactive_guide", class(guide))
-  guide
+  if (inherits(guide, "Guide")) {
+    return(ggproto_guide_interactive(guide))
+  } else {
+    class(guide) <- c(cl, "interactive_guide", class(guide))
+    guide
+  }
 }
 
 #' @export
@@ -104,7 +108,7 @@ copy_interactive_attrs_from_scale <- function(guide, scale, ipar = get_ipar(scal
           ), lbl_ip[[i]])
           do.call(label_interactive, args)
         })
-        if (guide$reverse) {
+        if (guide$reverse %||% guide$params$reverse) {
           labels <- rev(labels)
         }
         key$.label <- labels
@@ -134,10 +138,10 @@ copy_interactive_attrs_from_scale <- function(guide, scale, ipar = get_ipar(scal
 }
 
 # checks that all key ipar is in guide$geoms data
-check_guide_key_geoms <- function(guide) {
+check_guide_key_geoms <- function(guide, field = "geoms") {
   if (!is.null(guide)) {
     ipar = get_ipar(guide)
-    guide$geoms <- lapply(guide$geoms, function(g) {
+    guide[[field]] <- lapply(guide[[field]], function(g) {
       missing_names <- setdiff(ipar, names(g$data))
       missing_names <- intersect(missing_names, names(guide$key))
       if (length(missing_names)) {
@@ -152,3 +156,18 @@ check_guide_key_geoms <- function(guide) {
   guide
 }
 
+ggproto_guide_interactive <- function(guide) {
+  force(guide)
+  ggproto(
+    "GuideInteractive", guide,
+    override_elements = function(params, elements, theme) {
+      elements <- guide$override_elements(params, elements, theme)
+      elements$title <- as_interactive_element_text(elements$title)
+      attr(elements$title, "data_attr") <- "key-id"
+      elements$text <- as_interactive_element_text(elements$text)
+      attr(elements$text, "data_attr") <- "key-id"
+      elements
+    }
+  )
+}
+

R/guide_legend_interactive.R

@@ -14,8 +14,33 @@
 #' @example examples/scale_viridis_guide_legend_continuous_interactive.R
 #' @seealso [interactive_parameters], [girafe()]
 #' @export
-guide_legend_interactive <- function(...)
-  guide_interactive(guide_legend, "interactive_legend", ...)
+guide_legend_interactive <- function(...) {
+  guide <- guide_interactive(guide_legend, "interactive_legend", ...)
+  if (!inherits(guide, "Guide")) {
+    return(guide)
+  } else {
+    ggproto_legend_interactive(guide)
+  }
+}
+
+ggproto_legend_interactive <- function(guide) {
+  force(guide)
+  ggproto(
+    NULL, guide,
+    train = function(params, scale, aesthetic = NULL, ...) {
+      out <- guide$train(params, scale, aesthetic, ...)
+      if (!is.null(out)) {
+        out <- copy_interactive_attrs_from_scale(out, scale)
+      }
+      out
+    },
+    get_layer_key = function(params, layers) {
+      out <- guide$get_layer_key(params, layers)
+      out <- check_guide_key_geoms(out, "decor")
+      out
+    }
+  )
+}
 
 #' @export
 #' @importFrom purrr imap

R/scale_interactive.R

@@ -32,7 +32,7 @@ scale_interactive <- function(scale_func,
       # the name could be a guide set by guides() and it might be interactive, but also it might not.
       # should we display a warning here?
     }
-  } else if (inherits(sc$guide, "guide_none")) {
+  } else if (inherits(sc$guide, c("guide_none", "GuideNone"))) {
     # exit
     return(sc)
   } else if (inherits(sc$guide, "interactive_guide")) {
@@ -45,6 +45,25 @@ scale_interactive <- function(scale_func,
     class(sc$guide) <- c("interactive_coloursteps", "interactive_guide", class(sc$guide))
   } else if (inherits(sc$guide, "colourbar") || inherits(sc$guide, "colorbar")) {
     class(sc$guide) <- c("interactive_colourbar", "interactive_guide", class(sc$guide))
+  } else if (inherits(sc$guide, "Guide")) {
+    if (!inherits(sc$guide, "GuideInteractive")) {
+      classes <- paste0("Guide", c("Legend", "Bins", "Colourbar", "Coloursteps"))
+      inherit <- inherits(sc$guide, classes, which = TRUE)
+      if (sum(inherit != 0) > 0) {
+        inherit <- which(inherit == min(inherit[inherit != 0]))
+        guide <- ggproto_guide_interactive(sc$guide)
+        sc$guide <- switch(
+          inherit,
+          ggproto_legend_interactive(guide),
+          ggproto_legend_interactive(guide),
+          ggproto_colourbar_interactive(guide),
+          ggproto_colourbar_interactive(guide)
+        )
+      } else {
+        warning("Only `legend`, 'bins', `colourbar` and `coloursteps` guides are supported for interactivity")
+        return(sc)
+      }
+    }
   } else {
     warning("Only `legend`, 'bins', `colourbar` and `coloursteps` guides are supported for interactivity")
     return(sc)

inst/tinytest/setup.R

@@ -162,9 +162,9 @@ test_grob <- expression({
 test_guide <- expression({
   result <- do.call(name, list())
   # is guide?
-  expect_inherits(result, "guide", info = "result inherits guide")
+  expect_inherits(result, c("guide", "Guide"), info = "result inherits guide")
   # is interactive_guide?
-  expect_inherits(result, "interactive_guide", info = "result inherits interactive_guide")
+  expect_inherits(result, c("interactive_guide", "GuideInteractive"), info = "result inherits interactive_guide")
 })
 
 test_scale <- expression({

inst/tinytest/test-guide_bins_interactive.R

@@ -12,7 +12,11 @@ source("setup.R")
   scale <- scale_size_binned_interactive(
     guide = guide_bins(), tooltip = "tooltip"
   )
-  result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "size")
+  if (inherits(scale$guide, "Guide")) {
+    result <- scale$guide$train(scale$guide$params, scale, aesthetic = "size")
+  } else {
+    result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "size")
+  }
   expect_null(result)
 }
 {

inst/tinytest/test-guide_colourbar_interactive.R

@@ -13,7 +13,11 @@ source("setup.R")
   scale <- scale_colour_continuous_interactive(
     guide = guide_colourbar(), tooltip = "tooltip"
   )
-  result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "colour")
+  if (inherits(scale$guide, "Guide")) {
+    result <- scale$guide$train(scale$guide$params, scale, aesthetic = "colour")
+  } else {
+    result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "colour")
+  }
   expect_null(result)
 }
 {

inst/tinytest/test-guide_coloursteps_interactive.R

@@ -14,7 +14,11 @@ source("setup.R")
   scale <- scale_colour_continuous_interactive(
     guide = guide_coloursteps(), tooltip = "tooltip"
   )
-  result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "colour")
+  if (inherits(scale$guide, "Guide")) {
+    result <- scale$guide$train(scale$guide$params, scale, aesthetic = "colour")
+  } else {
+    result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "colour")
+  }
   expect_null(result)
 }
 {

inst/tinytest/test-guide_legend_interactive.R

@@ -12,7 +12,11 @@ source("setup.R")
   scale <- scale_colour_discrete_interactive(
     guide = guide_legend(), tooltip = "tooltip"
   )
-  result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "colour")
+  if (inherits(scale$guide, "Guide")) {
+    result <- scale$guide$train(scale$guide$params, scale, aesthetic = "colour")
+  } else {
+    result <- guide_train(guide = scale$guide, scale = scale, aesthetic = "colour")
+  }
   expect_null(result)
 }
 {

inst/tinytest/test-scale_interactive.R

@@ -28,14 +28,25 @@ scale_func <- scale_color_discrete_interactive
 }
 # scale_interactive with guide as guide object, is working ----
 {
-  scale <- scale_func(guide = guide_legend(), tooltip = "tooltip")
-  expect_inherits(scale$guide, c("interactive_guide", "interactive_legend"))
-  scale <- scale_func(guide = guide_bins(), tooltip = "tooltip")
-  expect_inherits(scale$guide, c("interactive_guide", "interactive_bins"))
-  scale <- scale_func(guide = guide_colorsteps(), tooltip = "tooltip")
-  expect_inherits(scale$guide, c("interactive_guide", "interactive_coloursteps"))
-  scale <- scale_func(guide = guide_colourbar(), tooltip = "tooltip")
-  expect_inherits(scale$guide, c("interactive_guide", "interactive_colourbar"))
+  if (inherits(guide_legend(), "Guide")) {
+    scale <- scale_func(guide = guide_legend(), tooltip = "tooltip")
+    expect_inherits(scale$guide, "GuideInteractive")
+    scale <- scale_func(guide = guide_bins(), tooltip = "tooltip")
+    expect_inherits(scale$guide, "GuideInteractive")
+    scale <- scale_func(guide = guide_colorsteps(), tooltip = "tooltip")
+    expect_inherits(scale$guide, "GuideInteractive")
+    scale <- scale_func(guide = guide_colourbar(), tooltip = "tooltip")
+    expect_inherits(scale$guide, "GuideInteractive")
+  } else {
+    scale <- scale_func(guide = guide_legend(), tooltip = "tooltip")
+    expect_inherits(scale$guide, c("interactive_guide", "interactive_legend"))
+    scale <- scale_func(guide = guide_bins(), tooltip = "tooltip")
+    expect_inherits(scale$guide, c("interactive_guide", "interactive_bins"))
+    scale <- scale_func(guide = guide_colorsteps(), tooltip = "tooltip")
+    expect_inherits(scale$guide, c("interactive_guide", "interactive_coloursteps"))
+    scale <- scale_func(guide = guide_colourbar(), tooltip = "tooltip")
+    expect_inherits(scale$guide, c("interactive_guide", "interactive_colourbar"))
+  }
 }
 
 # scale_interactive with unsupported guide, is working ----