diff --git a/R/guide_bins_interactive.R b/R/guide_bins_interactive.R index aa4b76ef..6b4eeb16 100644 --- a/R/guide_bins_interactive.R +++ b/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 diff --git a/R/guide_colourbar_interactive.R b/R/guide_colourbar_interactive.R index d57ebbcc..c9b1a8db 100644 --- a/R/guide_colourbar_interactive.R +++ b/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 diff --git a/R/guide_coloursteps_interactive.R b/R/guide_coloursteps_interactive.R index ead61df8..5b9266a8 100644 --- a/R/guide_coloursteps_interactive.R +++ b/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 diff --git a/R/guide_interactive.R b/R/guide_interactive.R index a43efc4e..2a5c976d 100644 --- a/R/guide_interactive.R +++ b/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 + } + ) +} + diff --git a/R/guide_legend_interactive.R b/R/guide_legend_interactive.R index 50479401..362706e1 100644 --- a/R/guide_legend_interactive.R +++ b/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 diff --git a/R/scale_interactive.R b/R/scale_interactive.R index 316335d6..061f108b 100644 --- a/R/scale_interactive.R +++ b/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) diff --git a/inst/tinytest/setup.R b/inst/tinytest/setup.R index 78d5429d..30393f69 100644 --- a/inst/tinytest/setup.R +++ b/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({ diff --git a/inst/tinytest/test-guide_bins_interactive.R b/inst/tinytest/test-guide_bins_interactive.R index 621d5c1a..04fa9f43 100644 --- a/inst/tinytest/test-guide_bins_interactive.R +++ b/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) } { diff --git a/inst/tinytest/test-guide_colourbar_interactive.R b/inst/tinytest/test-guide_colourbar_interactive.R index 7391fd78..5ba1bff7 100644 --- a/inst/tinytest/test-guide_colourbar_interactive.R +++ b/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) } { diff --git a/inst/tinytest/test-guide_coloursteps_interactive.R b/inst/tinytest/test-guide_coloursteps_interactive.R index 992750ec..b1b58027 100644 --- a/inst/tinytest/test-guide_coloursteps_interactive.R +++ b/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) } { diff --git a/inst/tinytest/test-guide_legend_interactive.R b/inst/tinytest/test-guide_legend_interactive.R index ba51defe..2337868b 100644 --- a/inst/tinytest/test-guide_legend_interactive.R +++ b/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) } { diff --git a/inst/tinytest/test-scale_interactive.R b/inst/tinytest/test-scale_interactive.R index cef039c3..1b1679d8 100644 --- a/inst/tinytest/test-scale_interactive.R +++ b/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 ----